adding tuples in ast_sugar
This commit is contained in:
parent
9cd750442a
commit
13e9405dee
@ -303,12 +303,12 @@ and eval : Ast_typed.expression -> env -> value result
|
|||||||
ok (label,v'))
|
ok (label,v'))
|
||||||
(LMap.to_kv_list recmap) in
|
(LMap.to_kv_list recmap) in
|
||||||
ok @@ V_Record (LMap.of_list lv')
|
ok @@ V_Record (LMap.of_list lv')
|
||||||
| E_record_accessor { record ; label} -> (
|
| E_record_accessor { record ; path} -> (
|
||||||
let%bind record' = eval record env in
|
let%bind record' = eval record env in
|
||||||
match record' with
|
match record' with
|
||||||
| V_Record recmap ->
|
| V_Record recmap ->
|
||||||
let%bind a = trace_option (simple_error "unknown record field") @@
|
let%bind a = trace_option (simple_error "unknown record field") @@
|
||||||
LMap.find_opt label recmap in
|
LMap.find_opt path recmap in
|
||||||
ok a
|
ok a
|
||||||
| _ -> simple_fail "trying to access a non-record"
|
| _ -> simple_fail "trying to access a non-record"
|
||||||
)
|
)
|
||||||
|
@ -172,7 +172,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
|
|||||||
aux node in
|
aux node in
|
||||||
ok @@ snd m'
|
ok @@ snd m'
|
||||||
| T_record m ->
|
| T_record m ->
|
||||||
let node = Append_tree.of_list @@ kv_list_of_lmap m in
|
let node = Append_tree.of_list @@ Stage_common.Helpers.kv_list_of_record_or_tuple m in
|
||||||
let aux a b : type_value annotated result =
|
let aux a b : type_value annotated result =
|
||||||
let%bind a = a in
|
let%bind a = a in
|
||||||
let%bind b = b in
|
let%bind b = b in
|
||||||
@ -191,7 +191,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
|
|||||||
)
|
)
|
||||||
|
|
||||||
let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
|
let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
|
||||||
let tys = kv_list_of_lmap tym in
|
let tys = Stage_common.Helpers.kv_list_of_record_or_tuple tym in
|
||||||
let node_tv = Append_tree.of_list tys in
|
let node_tv = Append_tree.of_list tys in
|
||||||
let%bind path =
|
let%bind path =
|
||||||
let aux (i , _) = i = ind in
|
let aux (i , _) = i = ind in
|
||||||
@ -290,7 +290,8 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
|
|||||||
return ~tv ae
|
return ~tv ae
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let node = Append_tree.of_list @@ list_of_lmap m in
|
(*list_of_lmap to record_to_list*)
|
||||||
|
let node = Append_tree.of_list @@ Stage_common.Helpers.list_of_record_or_tuple m in
|
||||||
let aux a b : expression result =
|
let aux a b : expression result =
|
||||||
let%bind a = a in
|
let%bind a = a in
|
||||||
let%bind b = b in
|
let%bind b = b in
|
||||||
@ -302,16 +303,15 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
|
|||||||
trace_strong (corner_case ~loc:__LOC__ "record build") @@
|
trace_strong (corner_case ~loc:__LOC__ "record build") @@
|
||||||
Append_tree.fold_ne (transpile_annotated_expression) aux node
|
Append_tree.fold_ne (transpile_annotated_expression) aux node
|
||||||
)
|
)
|
||||||
| E_record_accessor {record; label} ->
|
| E_record_accessor {record; path} ->
|
||||||
let ty = get_type_expression record in
|
let%bind ty' = transpile_type (get_type_expression record) in
|
||||||
let%bind ty' = transpile_type ty in
|
|
||||||
let%bind ty_lmap =
|
let%bind ty_lmap =
|
||||||
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
|
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
|
||||||
get_t_record ty in
|
get_t_record (get_type_expression record) in
|
||||||
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
|
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
|
||||||
let%bind path =
|
let%bind path =
|
||||||
trace_strong (corner_case ~loc:__LOC__ "record access") @@
|
trace_strong (corner_case ~loc:__LOC__ "record access") @@
|
||||||
record_access_to_lr ty' ty'_lmap label in
|
record_access_to_lr ty' ty'_lmap path in
|
||||||
let aux = fun pred (ty, lr) ->
|
let aux = fun pred (ty, lr) ->
|
||||||
let c = match lr with
|
let c = match lr with
|
||||||
| `Left -> C_CAR
|
| `Left -> C_CAR
|
||||||
|
@ -232,7 +232,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
|
|||||||
let%bind sub = untranspile v tv in
|
let%bind sub = untranspile v tv in
|
||||||
return (E_constructor {constructor=Constructor name;element=sub})
|
return (E_constructor {constructor=Constructor name;element=sub})
|
||||||
| T_record m ->
|
| T_record m ->
|
||||||
let lst = kv_list_of_lmap m in
|
let lst = Stage_common.Helpers.kv_list_of_record_or_tuple m in
|
||||||
let%bind node = match Append_tree.of_list lst with
|
let%bind node = match Append_tree.of_list lst with
|
||||||
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
|
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
|
||||||
| Full t -> ok t in
|
| Full t -> ok t in
|
||||||
|
@ -11,7 +11,7 @@ end
|
|||||||
open Errors
|
open Errors
|
||||||
|
|
||||||
let peephole_type_expression : type_expression -> type_expression result = fun e ->
|
let peephole_type_expression : type_expression -> type_expression result = fun e ->
|
||||||
let return type_content = ok { e with type_content } in
|
let return type_content = ok {type_content } in
|
||||||
match e.type_content with
|
match e.type_content with
|
||||||
| T_sum cmap ->
|
| T_sum cmap ->
|
||||||
let%bind _uu = bind_map_cmapi
|
let%bind _uu = bind_map_cmapi
|
||||||
|
@ -51,6 +51,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = self init' record in
|
let%bind res = self init' record in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
|
| E_tuple t -> (
|
||||||
|
let aux init'' expr =
|
||||||
|
let%bind res = fold_expression self init'' expr in
|
||||||
|
ok res
|
||||||
|
in
|
||||||
|
let%bind res = bind_fold_list aux (init') t in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
| E_tuple_update {tuple;update} -> (
|
||||||
|
let%bind res = self init' tuple in
|
||||||
|
let%bind res = fold_expression self res update in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
| E_tuple_accessor {tuple} -> (
|
||||||
|
let%bind res = self init' tuple in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
||||||
let%bind res = self init' rhs in
|
let%bind res = self init' rhs in
|
||||||
let%bind res = self res let_result in
|
let%bind res = self res let_result in
|
||||||
@ -161,6 +178,19 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind update = self update in
|
let%bind update = self update in
|
||||||
return @@ E_record_update {record;path;update}
|
return @@ E_record_update {record;path;update}
|
||||||
)
|
)
|
||||||
|
| E_tuple t -> (
|
||||||
|
let%bind t' = bind_map_list self t in
|
||||||
|
return @@ E_tuple t'
|
||||||
|
)
|
||||||
|
| E_tuple_update {tuple; path; update} -> (
|
||||||
|
let%bind tuple = self tuple in
|
||||||
|
let%bind update = self update in
|
||||||
|
return @@ E_tuple_update {tuple; path; update}
|
||||||
|
)
|
||||||
|
| E_tuple_accessor {tuple;path} -> (
|
||||||
|
let%bind tuple = self tuple in
|
||||||
|
return @@ E_tuple_accessor {tuple;path}
|
||||||
|
)
|
||||||
| E_constructor c -> (
|
| E_constructor c -> (
|
||||||
let%bind e' = self c.element in
|
let%bind e' = self c.element in
|
||||||
return @@ E_constructor {c with element = e'}
|
return @@ E_constructor {c with element = e'}
|
||||||
@ -212,7 +242,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
|
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
|
||||||
let self = map_type_expression f in
|
let self = map_type_expression f in
|
||||||
let%bind te' = f te in
|
let%bind te' = f te in
|
||||||
let return type_content = ok { te' with type_content } in
|
let return type_content = ok { type_content } in
|
||||||
match te'.type_content with
|
match te'.type_content with
|
||||||
| T_sum temap ->
|
| T_sum temap ->
|
||||||
let%bind temap' = bind_map_cmap self temap in
|
let%bind temap' = bind_map_cmap self temap in
|
||||||
@ -220,6 +250,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
|
|||||||
| T_record temap ->
|
| T_record temap ->
|
||||||
let%bind temap' = bind_map_lmap self temap in
|
let%bind temap' = bind_map_lmap self temap in
|
||||||
return @@ (T_record temap')
|
return @@ (T_record temap')
|
||||||
|
| T_tuple telst ->
|
||||||
|
let%bind telst' = bind_map_list self telst in
|
||||||
|
return @@ (T_tuple telst')
|
||||||
| T_arrow {type1 ; type2} ->
|
| T_arrow {type1 ; type2} ->
|
||||||
let%bind type1' = self type1 in
|
let%bind type1' = self type1 in
|
||||||
let%bind type2' = self type2 in
|
let%bind type2' = self type2 in
|
||||||
@ -324,6 +357,19 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res, update) = self res update in
|
let%bind (res, update) = self res update in
|
||||||
ok (res, return @@ E_record_update {record;path;update})
|
ok (res, return @@ E_record_update {record;path;update})
|
||||||
)
|
)
|
||||||
|
| E_tuple t -> (
|
||||||
|
let%bind (res, t') = bind_fold_map_list self init' t in
|
||||||
|
ok (res, return @@ E_tuple t')
|
||||||
|
)
|
||||||
|
| E_tuple_update {tuple; path; update} -> (
|
||||||
|
let%bind (res, tuple) = self init' tuple in
|
||||||
|
let%bind (res, update) = self res update in
|
||||||
|
ok (res, return @@ E_tuple_update {tuple;path;update})
|
||||||
|
)
|
||||||
|
| E_tuple_accessor {tuple; path} -> (
|
||||||
|
let%bind (res, tuple) = self init' tuple in
|
||||||
|
ok (res, return @@ E_tuple_accessor {tuple; path})
|
||||||
|
)
|
||||||
| E_constructor c -> (
|
| E_constructor c -> (
|
||||||
let%bind (res,e') = self init' c.element in
|
let%bind (res,e') = self init' c.element in
|
||||||
ok (res, return @@ E_constructor {c with element = e'})
|
ok (res, return @@ E_constructor {c with element = e'})
|
||||||
|
@ -123,6 +123,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ O.T_record (O.LMap.of_list record)
|
return @@ O.T_record (O.LMap.of_list record)
|
||||||
|
| I.T_tuple tuple ->
|
||||||
|
let%bind tuple = bind_map_list compile_type_expression tuple in
|
||||||
|
return @@ O.T_tuple tuple
|
||||||
| I.T_arrow {type1;type2} ->
|
| I.T_arrow {type1;type2} ->
|
||||||
let%bind type1 = compile_type_expression type1 in
|
let%bind type1 = compile_type_expression type1 in
|
||||||
let%bind type2 = compile_type_expression type2 in
|
let%bind type2 = compile_type_expression type2 in
|
||||||
@ -154,9 +157,6 @@ and compile_type_operator : I.type_operator -> O.type_operator result =
|
|||||||
| TC_big_map (k,v) ->
|
| TC_big_map (k,v) ->
|
||||||
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
|
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
|
||||||
ok @@ O.TC_big_map (k,v)
|
ok @@ O.TC_big_map (k,v)
|
||||||
| TC_map_or_big_map (k,v) ->
|
|
||||||
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
|
|
||||||
ok @@ O.TC_map_or_big_map (k,v)
|
|
||||||
| TC_arrow (i,o) ->
|
| TC_arrow (i,o) ->
|
||||||
let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in
|
let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in
|
||||||
ok @@ O.TC_arrow (i,o)
|
ok @@ O.TC_arrow (i,o)
|
||||||
@ -202,9 +202,9 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ O.E_record (O.LMap.of_list record)
|
return @@ O.E_record (O.LMap.of_list record)
|
||||||
| I.E_record_accessor {record;label} ->
|
| I.E_record_accessor {record;path} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
return @@ O.E_record_accessor {record;label}
|
return @@ O.E_record_accessor {record;path}
|
||||||
| I.E_record_update {record;path;update} ->
|
| I.E_record_update {record;path;update} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
let%bind update = compile_expression update in
|
let%bind update = compile_expression update in
|
||||||
@ -239,6 +239,16 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
let%bind expr2 = compile_expression expr2 in
|
let%bind expr2 = compile_expression expr2 in
|
||||||
ok @@ add_to_end expr1 expr2
|
ok @@ add_to_end expr1 expr2
|
||||||
| I.E_skip -> return @@ O.E_skip
|
| I.E_skip -> return @@ O.E_skip
|
||||||
|
| I.E_tuple tuple ->
|
||||||
|
let%bind tuple = bind_map_list compile_expression tuple in
|
||||||
|
return @@ O.E_tuple (tuple)
|
||||||
|
| I.E_tuple_accessor {tuple;path} ->
|
||||||
|
let%bind tuple = compile_expression tuple in
|
||||||
|
return @@ O.E_tuple_accessor {tuple;path}
|
||||||
|
| I.E_tuple_update {tuple;path;update} ->
|
||||||
|
let%bind tuple = compile_expression tuple in
|
||||||
|
let%bind update = compile_expression update in
|
||||||
|
return @@ O.E_tuple_update {tuple;path;update}
|
||||||
| I.E_assign ass ->
|
| I.E_assign ass ->
|
||||||
let%bind content = compile_assign ass @@ O.e_skip () in
|
let%bind content = compile_assign ass @@ O.e_skip () in
|
||||||
return @@ content
|
return @@ content
|
||||||
@ -282,7 +292,6 @@ and compile_assign {variable; access_path; expression} expr =
|
|||||||
let%bind rhs = rhs @@ expression in
|
let%bind rhs = rhs @@ expression in
|
||||||
ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false}
|
ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false}
|
||||||
|
|
||||||
|
|
||||||
and compile_lambda : I.lambda -> O.lambda result =
|
and compile_lambda : I.lambda -> O.lambda result =
|
||||||
fun {binder;input_type;output_type;result}->
|
fun {binder;input_type;output_type;result}->
|
||||||
let%bind input_type = bind_map_option compile_type_expression input_type in
|
let%bind input_type = bind_map_option compile_type_expression input_type in
|
||||||
@ -541,6 +550,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ I.T_record (O.LMap.of_list record)
|
return @@ I.T_record (O.LMap.of_list record)
|
||||||
|
| O.T_tuple tuple ->
|
||||||
|
let%bind tuple = bind_map_list uncompile_type_expression tuple in
|
||||||
|
return @@ I.T_tuple tuple
|
||||||
| O.T_arrow {type1;type2} ->
|
| O.T_arrow {type1;type2} ->
|
||||||
let%bind type1 = uncompile_type_expression type1 in
|
let%bind type1 = uncompile_type_expression type1 in
|
||||||
let%bind type2 = uncompile_type_expression type2 in
|
let%bind type2 = uncompile_type_expression type2 in
|
||||||
@ -572,9 +584,6 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
|
|||||||
| TC_big_map (k,v) ->
|
| TC_big_map (k,v) ->
|
||||||
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
|
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
|
||||||
ok @@ I.TC_big_map (k,v)
|
ok @@ I.TC_big_map (k,v)
|
||||||
| TC_map_or_big_map (k,v) ->
|
|
||||||
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
|
|
||||||
ok @@ I.TC_map_or_big_map (k,v)
|
|
||||||
| TC_arrow (i,o) ->
|
| TC_arrow (i,o) ->
|
||||||
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
|
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
|
||||||
ok @@ I.TC_arrow (i,o)
|
ok @@ I.TC_arrow (i,o)
|
||||||
@ -621,13 +630,23 @@ let rec uncompile_expression : O.expression -> I.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ I.E_record (O.LMap.of_list record)
|
return @@ I.E_record (O.LMap.of_list record)
|
||||||
| O.E_record_accessor {record;label} ->
|
| O.E_record_accessor {record;path} ->
|
||||||
let%bind record = uncompile_expression record in
|
let%bind record = uncompile_expression record in
|
||||||
return @@ I.E_record_accessor {record;label}
|
return @@ I.E_record_accessor {record;path}
|
||||||
| O.E_record_update {record;path;update} ->
|
| O.E_record_update {record;path;update} ->
|
||||||
let%bind record = uncompile_expression record in
|
let%bind record = uncompile_expression record in
|
||||||
let%bind update = uncompile_expression update in
|
let%bind update = uncompile_expression update in
|
||||||
return @@ I.E_record_update {record;path;update}
|
return @@ I.E_record_update {record;path;update}
|
||||||
|
| O.E_tuple tuple ->
|
||||||
|
let%bind tuple = bind_map_list uncompile_expression tuple in
|
||||||
|
return @@ I.E_tuple tuple
|
||||||
|
| O.E_tuple_accessor {tuple;path} ->
|
||||||
|
let%bind tuple = uncompile_expression tuple in
|
||||||
|
return @@ I.E_tuple_accessor {tuple;path}
|
||||||
|
| O.E_tuple_update {tuple;path;update} ->
|
||||||
|
let%bind tuple = uncompile_expression tuple in
|
||||||
|
let%bind update = uncompile_expression update in
|
||||||
|
return @@ I.E_tuple_update {tuple;path;update}
|
||||||
| O.E_map map ->
|
| O.E_map map ->
|
||||||
let%bind map = bind_map_list (
|
let%bind map = bind_map_list (
|
||||||
bind_map_pair uncompile_expression
|
bind_map_pair uncompile_expression
|
||||||
|
@ -63,6 +63,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let ab = (expr1,expr2) in
|
let ab = (expr1,expr2) in
|
||||||
let%bind res = bind_fold_pair self init' ab in
|
let%bind res = bind_fold_pair self init' ab in
|
||||||
ok res
|
ok res
|
||||||
|
| E_tuple t -> (
|
||||||
|
let aux init'' expr =
|
||||||
|
let%bind res = fold_expression self init'' expr in
|
||||||
|
ok res
|
||||||
|
in
|
||||||
|
let%bind res = bind_fold_list aux (init') t in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
| E_tuple_update {tuple;update} -> (
|
||||||
|
let%bind res = self init' tuple in
|
||||||
|
let%bind res = fold_expression self res update in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
| E_tuple_accessor {tuple} -> (
|
||||||
|
let%bind res = self init' tuple in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||||
@ -176,12 +193,25 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
|
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
|
||||||
return @@ E_sequence {expr1;expr2}
|
return @@ E_sequence {expr1;expr2}
|
||||||
)
|
)
|
||||||
|
| E_tuple t -> (
|
||||||
|
let%bind t' = bind_map_list self t in
|
||||||
|
return @@ E_tuple t'
|
||||||
|
)
|
||||||
|
| E_tuple_update {tuple; path; update} -> (
|
||||||
|
let%bind tuple = self tuple in
|
||||||
|
let%bind update = self update in
|
||||||
|
return @@ E_tuple_update {tuple; path; update}
|
||||||
|
)
|
||||||
|
| E_tuple_accessor {tuple;path} -> (
|
||||||
|
let%bind tuple = self tuple in
|
||||||
|
return @@ E_tuple_accessor {tuple;path}
|
||||||
|
)
|
||||||
| E_literal _ | E_variable _ | E_skip as e' -> return e'
|
| E_literal _ | E_variable _ | E_skip as e' -> return e'
|
||||||
|
|
||||||
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
|
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
|
||||||
let self = map_type_expression f in
|
let self = map_type_expression f in
|
||||||
let%bind te' = f te in
|
let%bind te' = f te in
|
||||||
let return type_content = ok { te' with type_content } in
|
let return type_content = ok { type_content } in
|
||||||
match te'.type_content with
|
match te'.type_content with
|
||||||
| T_sum temap ->
|
| T_sum temap ->
|
||||||
let%bind temap' = bind_map_cmap self temap in
|
let%bind temap' = bind_map_cmap self temap in
|
||||||
@ -189,6 +219,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
|
|||||||
| T_record temap ->
|
| T_record temap ->
|
||||||
let%bind temap' = bind_map_lmap self temap in
|
let%bind temap' = bind_map_lmap self temap in
|
||||||
return @@ (T_record temap')
|
return @@ (T_record temap')
|
||||||
|
| T_tuple telst ->
|
||||||
|
let%bind telst' = bind_map_list self telst in
|
||||||
|
return @@ (T_tuple telst')
|
||||||
| T_arrow {type1 ; type2} ->
|
| T_arrow {type1 ; type2} ->
|
||||||
let%bind type1' = self type1 in
|
let%bind type1' = self type1 in
|
||||||
let%bind type2' = self type2 in
|
let%bind type2' = self type2 in
|
||||||
@ -293,6 +326,19 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res, update) = self res update in
|
let%bind (res, update) = self res update in
|
||||||
ok (res, return @@ E_record_update {record;path;update})
|
ok (res, return @@ E_record_update {record;path;update})
|
||||||
)
|
)
|
||||||
|
| E_tuple t -> (
|
||||||
|
let%bind (res, t') = bind_fold_map_list self init' t in
|
||||||
|
ok (res, return @@ E_tuple t')
|
||||||
|
)
|
||||||
|
| E_tuple_update {tuple; path; update} -> (
|
||||||
|
let%bind (res, tuple) = self init' tuple in
|
||||||
|
let%bind (res, update) = self res update in
|
||||||
|
ok (res, return @@ E_tuple_update {tuple;path;update})
|
||||||
|
)
|
||||||
|
| E_tuple_accessor {tuple; path} -> (
|
||||||
|
let%bind (res, tuple) = self init' tuple in
|
||||||
|
ok (res, return @@ E_tuple_accessor {tuple; path})
|
||||||
|
)
|
||||||
| E_constructor c -> (
|
| E_constructor c -> (
|
||||||
let%bind (res,e') = self init' c.element in
|
let%bind (res,e') = self init' c.element in
|
||||||
ok (res, return @@ E_constructor {c with element = e'})
|
ok (res, return @@ E_constructor {c with element = e'})
|
||||||
|
@ -24,6 +24,13 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ O.T_record (O.LMap.of_list record)
|
return @@ O.T_record (O.LMap.of_list record)
|
||||||
|
| I.T_tuple tuple ->
|
||||||
|
let aux (i,acc) el =
|
||||||
|
let%bind el = idle_type_expression el in
|
||||||
|
ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in
|
||||||
|
let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in
|
||||||
|
let record = O.LMap.of_list lst in
|
||||||
|
return @@ O.T_record record
|
||||||
| I.T_arrow {type1;type2} ->
|
| I.T_arrow {type1;type2} ->
|
||||||
let%bind type1 = idle_type_expression type1 in
|
let%bind type1 = idle_type_expression type1 in
|
||||||
let%bind type2 = idle_type_expression type2 in
|
let%bind type2 = idle_type_expression type2 in
|
||||||
@ -55,9 +62,6 @@ and idle_type_operator : I.type_operator -> O.type_operator result =
|
|||||||
| TC_big_map (k,v) ->
|
| TC_big_map (k,v) ->
|
||||||
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
|
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
|
||||||
ok @@ O.TC_big_map (k,v)
|
ok @@ O.TC_big_map (k,v)
|
||||||
| TC_map_or_big_map (k,v) ->
|
|
||||||
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
|
|
||||||
ok @@ O.TC_map_or_big_map (k,v)
|
|
||||||
| TC_arrow (i,o) ->
|
| TC_arrow (i,o) ->
|
||||||
let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in
|
let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in
|
||||||
ok @@ O.TC_arrow (i,o)
|
ok @@ O.TC_arrow (i,o)
|
||||||
@ -104,9 +108,9 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ O.E_record (O.LMap.of_list record)
|
return @@ O.E_record (O.LMap.of_list record)
|
||||||
| I.E_record_accessor {record;label} ->
|
| I.E_record_accessor {record;path} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
return @@ O.E_record_accessor {record;label}
|
return @@ O.E_record_accessor {record;path}
|
||||||
| I.E_record_update {record;path;update} ->
|
| I.E_record_update {record;path;update} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
let%bind update = compile_expression update in
|
let%bind update = compile_expression update in
|
||||||
@ -155,6 +159,22 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
let%bind expr2 = compile_expression expr2 in
|
let%bind expr2 = compile_expression expr2 in
|
||||||
return @@ O.E_let_in {let_binder=(Var.of_name "_", Some O.t_unit); rhs=expr1;let_result=expr2; inline=false}
|
return @@ O.E_let_in {let_binder=(Var.of_name "_", Some O.t_unit); rhs=expr1;let_result=expr2; inline=false}
|
||||||
| I.E_skip -> ok @@ O.e_unit ~loc:e.location ()
|
| I.E_skip -> ok @@ O.e_unit ~loc:e.location ()
|
||||||
|
| I.E_tuple t ->
|
||||||
|
let aux (i,acc) el =
|
||||||
|
let%bind el = compile_expression el in
|
||||||
|
ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in
|
||||||
|
let%bind (_, lst ) = bind_fold_list aux (0,[]) t in
|
||||||
|
let m = O.LMap.of_list lst in
|
||||||
|
return @@ O.E_record m
|
||||||
|
| I.E_tuple_accessor {tuple;path} ->
|
||||||
|
let%bind record = compile_expression tuple in
|
||||||
|
let path = O.Label (string_of_int path) in
|
||||||
|
return @@ O.E_record_accessor {record;path}
|
||||||
|
| I.E_tuple_update {tuple;path;update} ->
|
||||||
|
let%bind record = compile_expression tuple in
|
||||||
|
let path = O.Label (string_of_int path) in
|
||||||
|
let%bind update = compile_expression update in
|
||||||
|
return @@ O.E_record_update {record;path;update}
|
||||||
|
|
||||||
and compile_lambda : I.lambda -> O.lambda result =
|
and compile_lambda : I.lambda -> O.lambda result =
|
||||||
fun {binder;input_type;output_type;result}->
|
fun {binder;input_type;output_type;result}->
|
||||||
@ -261,9 +281,7 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
|
|||||||
| TC_big_map (k,v) ->
|
| TC_big_map (k,v) ->
|
||||||
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
|
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
|
||||||
ok @@ I.TC_big_map (k,v)
|
ok @@ I.TC_big_map (k,v)
|
||||||
| TC_map_or_big_map (k,v) ->
|
| TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled"
|
||||||
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
|
|
||||||
ok @@ I.TC_map_or_big_map (k,v)
|
|
||||||
| TC_arrow (i,o) ->
|
| TC_arrow (i,o) ->
|
||||||
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
|
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
|
||||||
ok @@ I.TC_arrow (i,o)
|
ok @@ I.TC_arrow (i,o)
|
||||||
@ -314,9 +332,9 @@ let rec uncompile_expression : O.expression -> I.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ I.E_record (O.LMap.of_list record)
|
return @@ I.E_record (O.LMap.of_list record)
|
||||||
| O.E_record_accessor {record;label} ->
|
| O.E_record_accessor {record;path} ->
|
||||||
let%bind record = uncompile_expression record in
|
let%bind record = uncompile_expression record in
|
||||||
return @@ I.E_record_accessor {record;label}
|
return @@ I.E_record_accessor {record;path}
|
||||||
| O.E_record_update {record;path;update} ->
|
| O.E_record_update {record;path;update} ->
|
||||||
let%bind record = uncompile_expression record in
|
let%bind record = uncompile_expression record in
|
||||||
let%bind update = uncompile_expression update in
|
let%bind update = uncompile_expression update in
|
||||||
|
@ -455,10 +455,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
|
|||||||
* | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
|
* | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
|
||||||
* | _ -> return (E_literal (Literal_string s)) (t_string ())
|
* | _ -> return (E_literal (Literal_string s)) (t_string ())
|
||||||
* ) *)
|
* ) *)
|
||||||
| E_record_accessor {record;label} -> (
|
| E_record_accessor {record;path} -> (
|
||||||
let%bind (base' , state') = type_expression e state record in
|
let%bind (base' , state') = type_expression e state record in
|
||||||
let wrapped = Wrap.access_label ~base:base'.type_expression ~label in
|
let wrapped = Wrap.access_label ~base:base'.type_expression ~label:path in
|
||||||
return_wrapped (E_record_accessor {record=base';label}) state' wrapped
|
return_wrapped (E_record_accessor {record=base';path}) state' wrapped
|
||||||
)
|
)
|
||||||
|
|
||||||
(* Sum *)
|
(* Sum *)
|
||||||
@ -917,15 +917,15 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
let%bind r' = bind_smap
|
let%bind r' = bind_smap
|
||||||
@@ Map.String.map untype_expression r in
|
@@ Map.String.map untype_expression r in
|
||||||
return (e_record r')
|
return (e_record r')
|
||||||
| E_record_accessor {record; label} ->
|
| E_record_accessor {record; path} ->
|
||||||
let%bind r' = untype_expression record in
|
let%bind r' = untype_expression record in
|
||||||
let Label s = label in
|
let Label s = path in
|
||||||
return (e_accessor r' s)
|
return (e_record_accessor r' s)
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
let%bind r' = untype_expression record in
|
let%bind r' = untype_expression record in
|
||||||
let%bind e = untype_expression update in
|
let%bind e = untype_expression update in
|
||||||
let Label l = path in
|
let Label l = path in
|
||||||
return (e_update r' l e)
|
return (e_record_update r' l e)
|
||||||
| E_matching {matchee;cases} ->
|
| E_matching {matchee;cases} ->
|
||||||
let%bind ae' = untype_expression matchee in
|
let%bind ae' = untype_expression matchee in
|
||||||
let%bind m' = untype_matching untype_expression cases in
|
let%bind m' = untype_matching untype_expression cases in
|
||||||
|
@ -454,7 +454,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
|||||||
return (e_address s) (t_address ())
|
return (e_address s) (t_address ())
|
||||||
| E_literal (Literal_operation op) ->
|
| E_literal (Literal_operation op) ->
|
||||||
return (e_operation op) (t_operation ())
|
return (e_operation op) (t_operation ())
|
||||||
| E_record_accessor {record;label} ->
|
| E_record_accessor {record;path} ->
|
||||||
let%bind e' = type_expression' e record in
|
let%bind e' = type_expression' e record in
|
||||||
let aux (prev:O.expression) (a:I.label) : O.expression result =
|
let aux (prev:O.expression) (a:I.label) : O.expression result =
|
||||||
let property = a in
|
let property = a in
|
||||||
@ -463,10 +463,10 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
|||||||
generic_try (bad_record_access property ae prev.type_expression ae.location)
|
generic_try (bad_record_access property ae prev.type_expression ae.location)
|
||||||
@@ (fun () -> I.LMap.find property r_tv) in
|
@@ (fun () -> I.LMap.find property r_tv) in
|
||||||
let location = ae.location in
|
let location = ae.location in
|
||||||
ok @@ make_a_e ~location (E_record_accessor {record=prev; label=property}) tv e
|
ok @@ make_a_e ~location (E_record_accessor {record=prev; path=property}) tv e
|
||||||
in
|
in
|
||||||
let%bind ae =
|
let%bind ae =
|
||||||
trace (simple_info "accessing") @@ aux e' label in
|
trace (simple_info "accessing") @@ aux e' path in
|
||||||
(* check type annotation of the final accessed element *)
|
(* check type annotation of the final accessed element *)
|
||||||
let%bind () =
|
let%bind () =
|
||||||
match tv_opt with
|
match tv_opt with
|
||||||
@ -787,15 +787,15 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
let%bind r' = bind_smap
|
let%bind r' = bind_smap
|
||||||
@@ Map.String.map untype_expression r in
|
@@ Map.String.map untype_expression r in
|
||||||
return (e_record r')
|
return (e_record r')
|
||||||
| E_record_accessor {record; label} ->
|
| E_record_accessor {record; path} ->
|
||||||
let%bind r' = untype_expression record in
|
let%bind r' = untype_expression record in
|
||||||
let Label s = label in
|
let Label s = path in
|
||||||
return (e_accessor r' s)
|
return (e_record_accessor r' s)
|
||||||
| E_record_update {record=r; path=l; update=e} ->
|
| E_record_update {record=r; path=l; update=e} ->
|
||||||
let%bind r' = untype_expression r in
|
let%bind r' = untype_expression r in
|
||||||
let%bind e = untype_expression e in
|
let%bind e = untype_expression e in
|
||||||
let Label l = l in
|
let Label l = l in
|
||||||
return (e_update r' l e)
|
return (e_record_update r' l e)
|
||||||
| E_matching {matchee;cases} ->
|
| E_matching {matchee;cases} ->
|
||||||
let%bind ae' = untype_expression matchee in
|
let%bind ae' = untype_expression matchee in
|
||||||
let%bind m' = untype_matching untype_expression cases in
|
let%bind m' = untype_matching untype_expression cases in
|
||||||
|
@ -91,9 +91,9 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
|||||||
let%bind cases' = map_cases f cases in
|
let%bind cases' = map_cases f cases in
|
||||||
return @@ E_matching {matchee=e';cases=cases'}
|
return @@ E_matching {matchee=e';cases=cases'}
|
||||||
)
|
)
|
||||||
| E_record_accessor acc -> (
|
| E_record_accessor {record; path} -> (
|
||||||
let%bind e' = self acc.record in
|
let%bind record = self record in
|
||||||
return @@ E_record_accessor {acc with record = e'}
|
return @@ E_record_accessor {record; path}
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let%bind m' = bind_map_lmap self m in
|
let%bind m' = bind_map_lmap self m in
|
||||||
@ -186,9 +186,9 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res,cases') = fold_map_cases f res cases in
|
let%bind (res,cases') = fold_map_cases f res cases in
|
||||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
||||||
)
|
)
|
||||||
| E_record_accessor acc -> (
|
| E_record_accessor {record; path} -> (
|
||||||
let%bind (res, e') = self init' acc.record in
|
let%bind (res, record) = self init' record in
|
||||||
ok (res, return @@ E_record_accessor {acc with record = e'})
|
ok (res, return @@ E_record_accessor {record; path})
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
||||||
|
@ -4,11 +4,45 @@ open Format
|
|||||||
open PP_helpers
|
open PP_helpers
|
||||||
|
|
||||||
include Stage_common.PP
|
include Stage_common.PP
|
||||||
include Ast_PP_type(Ast_imperative_parameter)
|
|
||||||
|
|
||||||
let expression_variable ppf (ev : expression_variable) : unit =
|
let expression_variable ppf (ev : expression_variable) : unit =
|
||||||
fprintf ppf "%a" Var.pp ev
|
fprintf ppf "%a" Var.pp ev
|
||||||
|
|
||||||
|
let rec type_expression' :
|
||||||
|
(formatter -> type_expression -> unit)
|
||||||
|
-> formatter
|
||||||
|
-> type_expression
|
||||||
|
-> unit =
|
||||||
|
fun f ppf te ->
|
||||||
|
match te.type_content with
|
||||||
|
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
|
||||||
|
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
|
||||||
|
| T_tuple t -> fprintf ppf "%a" (list_sep_d f) t
|
||||||
|
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
|
||||||
|
| T_variable tv -> type_variable ppf tv
|
||||||
|
| T_constant tc -> type_constant ppf tc
|
||||||
|
| T_operator to_ -> type_operator f ppf to_
|
||||||
|
|
||||||
|
and type_expression ppf (te : type_expression) : unit =
|
||||||
|
type_expression' type_expression ppf te
|
||||||
|
|
||||||
|
and type_operator :
|
||||||
|
(formatter -> type_expression -> unit)
|
||||||
|
-> formatter
|
||||||
|
-> type_operator
|
||||||
|
-> unit =
|
||||||
|
fun f ppf to_ ->
|
||||||
|
let s =
|
||||||
|
match to_ with
|
||||||
|
| TC_option te -> Format.asprintf "option(%a)" f te
|
||||||
|
| TC_list te -> Format.asprintf "list(%a)" f te
|
||||||
|
| TC_set te -> Format.asprintf "set(%a)" f te
|
||||||
|
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
|
||||||
|
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
|
||||||
|
| TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
|
||||||
|
| TC_contract te -> Format.asprintf "Contract (%a)" f te
|
||||||
|
in
|
||||||
|
fprintf ppf "(TO_%s)" s
|
||||||
|
|
||||||
let rec expression ppf (e : expression) =
|
let rec expression ppf (e : expression) =
|
||||||
expression_content ppf e.expression_content
|
expression_content ppf e.expression_content
|
||||||
@ -27,8 +61,8 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
c.arguments
|
c.arguments
|
||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
||||||
| E_record_accessor {record; label=l}->
|
| E_record_accessor ra ->
|
||||||
fprintf ppf "%a.%a" expression record label l
|
fprintf ppf "%a.%a" expression ra.record label ra.path
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
||||||
| E_map m ->
|
| E_map m ->
|
||||||
@ -66,6 +100,12 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
|
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
|
||||||
| E_skip ->
|
| E_skip ->
|
||||||
fprintf ppf "skip"
|
fprintf ppf "skip"
|
||||||
|
| E_tuple t ->
|
||||||
|
fprintf ppf "%a" (list_sep_d expression) t
|
||||||
|
| E_tuple_accessor ta ->
|
||||||
|
fprintf ppf "%a.%d" expression ta.tuple ta.path
|
||||||
|
| E_tuple_update {tuple; path; update} ->
|
||||||
|
fprintf ppf "{ %a with { %d = %a } }" expression tuple path expression update
|
||||||
| E_assign {variable; access_path; expression=e} ->
|
| E_assign {variable; access_path; expression=e} ->
|
||||||
fprintf ppf "%a%a := %a"
|
fprintf ppf "%a%a := %a"
|
||||||
expression_variable variable
|
expression_variable variable
|
||||||
|
@ -19,14 +19,9 @@ module Errors = struct
|
|||||||
end
|
end
|
||||||
open Errors
|
open Errors
|
||||||
|
|
||||||
let make_t type_content = {type_content; type_meta = ()}
|
let make_t type_content = {type_content}
|
||||||
|
|
||||||
|
|
||||||
let tuple_to_record lst =
|
|
||||||
let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in
|
|
||||||
let (_, lst ) = List.fold_left aux (0,[]) lst in
|
|
||||||
lst
|
|
||||||
|
|
||||||
let t_bool : type_expression = make_t @@ T_constant (TC_bool)
|
let t_bool : type_expression = make_t @@ T_constant (TC_bool)
|
||||||
let t_string : type_expression = make_t @@ T_constant (TC_string)
|
let t_string : type_expression = make_t @@ T_constant (TC_string)
|
||||||
let t_bytes : type_expression = make_t @@ T_constant (TC_bytes)
|
let t_bytes : type_expression = make_t @@ T_constant (TC_bytes)
|
||||||
@ -51,8 +46,8 @@ let t_record m : type_expression =
|
|||||||
let lst = Map.String.to_kv_list m in
|
let lst = Map.String.to_kv_list m in
|
||||||
t_record_ez lst
|
t_record_ez lst
|
||||||
|
|
||||||
let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)]
|
let t_tuple lst : type_expression = make_t @@ T_tuple lst
|
||||||
let t_tuple lst : type_expression = t_record_ez (tuple_to_record lst)
|
let t_pair (a , b) : type_expression = t_tuple [a; b]
|
||||||
|
|
||||||
let ez_t_sum (lst:(string * type_expression) list) : type_expression =
|
let ez_t_sum (lst:(string * type_expression) list) : type_expression =
|
||||||
let aux prev (k, v) = CMap.add (Constructor k) v prev in
|
let aux prev (k, v) = CMap.add (Constructor k) v prev in
|
||||||
@ -118,7 +113,8 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
|
|||||||
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
||||||
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
||||||
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
||||||
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b}
|
let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b}
|
||||||
|
let e_accessor ?loc a b = e_record_accessor ?loc a b
|
||||||
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
||||||
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
||||||
let e_skip ?loc () = make_expr ?loc @@ E_skip
|
let e_skip ?loc () = make_expr ?loc @@ E_skip
|
||||||
@ -151,11 +147,12 @@ let e_record ?loc map =
|
|||||||
let lst = Map.String.to_kv_list map in
|
let lst = Map.String.to_kv_list map in
|
||||||
e_record_ez ?loc lst
|
e_record_ez ?loc lst
|
||||||
|
|
||||||
let e_update ?loc record path update =
|
let e_record_update ?loc record path update =
|
||||||
let path = Label path in
|
let path = Label path in
|
||||||
make_expr ?loc @@ E_record_update {record; path; update}
|
make_expr ?loc @@ E_record_update {record; path; update}
|
||||||
|
let e_update ?loc record path update = e_record_update ?loc record path update
|
||||||
|
|
||||||
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
|
let e_tuple ?loc lst : expression = make_expr ?loc @@ E_tuple lst
|
||||||
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
|
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
|
||||||
|
|
||||||
let make_option_typed ?loc e t_opt =
|
let make_option_typed ?loc e t_opt =
|
||||||
@ -201,7 +198,7 @@ let e_ez_assign ?loc variable access_path expression =
|
|||||||
|
|
||||||
let get_e_accessor = fun t ->
|
let get_e_accessor = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record_accessor {record; label} -> ok (record , label)
|
| E_record_accessor {record; path} -> ok (record , path)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not an accessor"
|
||||||
|
|
||||||
let assert_e_accessor = fun t ->
|
let assert_e_accessor = fun t ->
|
||||||
@ -210,14 +207,7 @@ let assert_e_accessor = fun t ->
|
|||||||
|
|
||||||
let get_e_pair = fun t ->
|
let get_e_pair = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record r -> (
|
| E_tuple [a ; b] -> ok (a , b)
|
||||||
let lst = LMap.to_kv_list r in
|
|
||||||
match lst with
|
|
||||||
| [(Label "O",a);(Label "1",b)]
|
|
||||||
| [(Label "1",b);(Label "0",a)] ->
|
|
||||||
ok (a , b)
|
|
||||||
| _ -> simple_fail "not a pair"
|
|
||||||
)
|
|
||||||
| _ -> simple_fail "not a pair"
|
| _ -> simple_fail "not a pair"
|
||||||
|
|
||||||
let get_e_list = fun t ->
|
let get_e_list = fun t ->
|
||||||
@ -225,29 +215,15 @@ let get_e_list = fun t ->
|
|||||||
| E_list lst -> ok lst
|
| E_list lst -> ok lst
|
||||||
| _ -> simple_fail "not a list"
|
| _ -> simple_fail "not a list"
|
||||||
|
|
||||||
let tuple_of_record (m: _ LMap.t) =
|
|
||||||
let aux i =
|
|
||||||
let opt = LMap.find_opt (Label (string_of_int i)) m in
|
|
||||||
Option.bind (fun opt -> Some (opt,i+1)) opt
|
|
||||||
in
|
|
||||||
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
|
|
||||||
|
|
||||||
let get_e_tuple = fun t ->
|
let get_e_tuple = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record r -> ok @@ tuple_of_record r
|
| E_tuple t -> ok @@ t
|
||||||
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
|
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
|
||||||
|
|
||||||
(* Same as get_e_pair *)
|
(* Same as get_e_pair *)
|
||||||
let extract_pair : expression -> (expression * expression) result = fun e ->
|
let extract_pair : expression -> (expression * expression) result = fun e ->
|
||||||
match e.expression_content with
|
match e.expression_content with
|
||||||
| E_record r -> (
|
| E_tuple [a;b] -> ok @@ (a,b)
|
||||||
let lst = LMap.to_kv_list r in
|
|
||||||
match lst with
|
|
||||||
| [(Label "O",a);(Label "1",b)]
|
|
||||||
| [(Label "1",b);(Label "0",a)] ->
|
|
||||||
ok (a , b)
|
|
||||||
| _ -> fail @@ bad_kind "pair" e.location
|
|
||||||
)
|
|
||||||
| _ -> fail @@ bad_kind "pair" e.location
|
| _ -> fail @@ bad_kind "pair" e.location
|
||||||
|
|
||||||
let extract_list : expression -> (expression list) result = fun e ->
|
let extract_list : expression -> (expression list) result = fun e ->
|
||||||
|
@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
|
|||||||
| E_record_update _, _ ->
|
| E_record_update _, _ ->
|
||||||
simple_fail "comparing record update with other expression"
|
simple_fail "comparing record update with other expression"
|
||||||
|
|
||||||
|
| E_tuple lsta, E_tuple lstb -> (
|
||||||
|
let%bind lst =
|
||||||
|
generic_try (simple_error "tuples with different number of elements")
|
||||||
|
(fun () -> List.combine lsta lstb) in
|
||||||
|
let%bind _all = bind_list @@ List.map assert_value_eq lst in
|
||||||
|
ok ()
|
||||||
|
)
|
||||||
|
| E_tuple _, _ ->
|
||||||
|
simple_fail "comparing tuple with other expression"
|
||||||
|
|
||||||
|
| E_tuple_update uta, E_tuple_update utb ->
|
||||||
|
let _ =
|
||||||
|
generic_try (simple_error "Updating different tuple") @@
|
||||||
|
fun () -> assert_value_eq (uta.tuple, utb.tuple) in
|
||||||
|
let () = assert (uta.path == utb.path) in
|
||||||
|
let%bind () = assert_value_eq (uta.update,utb.update) in
|
||||||
|
ok ()
|
||||||
|
| E_tuple_update _, _ ->
|
||||||
|
simple_fail "comparing tuple update with other expression"
|
||||||
|
|
||||||
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
|
| (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")
|
let%bind lst = generic_try (simple_error "maps of different lengths")
|
||||||
(fun () ->
|
(fun () ->
|
||||||
@ -182,7 +202,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
|
|||||||
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
|
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
|
||||||
| (E_variable _, _) | (E_lambda _, _)
|
| (E_variable _, _) | (E_lambda _, _)
|
||||||
| (E_application _, _) | (E_let_in _, _)
|
| (E_application _, _) | (E_let_in _, _)
|
||||||
| (E_recursive _,_) | (E_record_accessor _, _)
|
| (E_recursive _,_)
|
||||||
|
| (E_record_accessor _, _) | (E_tuple_accessor _, _)
|
||||||
| (E_look_up _, _) | (E_matching _, _)
|
| (E_look_up _, _) | (E_matching _, _)
|
||||||
| (E_sequence _, _) | (E_skip, _)
|
| (E_sequence _, _) | (E_skip, _)
|
||||||
| (E_assign _, _)
|
| (E_assign _, _)
|
||||||
|
@ -2,17 +2,31 @@
|
|||||||
|
|
||||||
module Location = Simple_utils.Location
|
module Location = Simple_utils.Location
|
||||||
|
|
||||||
module Ast_imperative_parameter = struct
|
|
||||||
type type_meta = unit
|
|
||||||
end
|
|
||||||
|
|
||||||
include Stage_common.Types
|
include Stage_common.Types
|
||||||
|
|
||||||
(*include Ast_generic_type(Ast_core_parameter)
|
type type_content =
|
||||||
*)
|
| T_sum of type_expression constructor_map
|
||||||
include Ast_generic_type (Ast_imperative_parameter)
|
| T_record of type_expression label_map
|
||||||
|
| T_tuple of type_expression list
|
||||||
|
| T_arrow of arrow
|
||||||
|
| T_variable of type_variable
|
||||||
|
| T_constant of type_constant
|
||||||
|
| T_operator of type_operator
|
||||||
|
|
||||||
|
and arrow = {type1: type_expression; type2: type_expression}
|
||||||
|
|
||||||
|
and type_operator =
|
||||||
|
| TC_contract of type_expression
|
||||||
|
| TC_option of type_expression
|
||||||
|
| TC_list of type_expression
|
||||||
|
| TC_set of type_expression
|
||||||
|
| TC_map of type_expression * type_expression
|
||||||
|
| TC_big_map of type_expression * type_expression
|
||||||
|
| TC_arrow of type_expression * type_expression
|
||||||
|
|
||||||
|
and type_expression = {type_content: type_content}
|
||||||
|
|
||||||
|
|
||||||
type inline = bool
|
|
||||||
type program = declaration Location.wrap list
|
type program = declaration Location.wrap list
|
||||||
and declaration =
|
and declaration =
|
||||||
| Declaration_type of (type_variable * type_expression)
|
| Declaration_type of (type_variable * type_expression)
|
||||||
@ -22,7 +36,7 @@ and declaration =
|
|||||||
* an optional type annotation
|
* an optional type annotation
|
||||||
* a boolean indicating whether it should be inlined
|
* a boolean indicating whether it should be inlined
|
||||||
* an expression *)
|
* an expression *)
|
||||||
| Declaration_constant of (expression_variable * type_expression option * inline * expression)
|
| Declaration_constant of (expression_variable * type_expression option * bool * expression)
|
||||||
|
|
||||||
(* | Macro_declaration of macro_declaration *)
|
(* | Macro_declaration of macro_declaration *)
|
||||||
and expression = {expression_content: expression_content; location: Location.t}
|
and expression = {expression_content: expression_content; location: Location.t}
|
||||||
@ -41,13 +55,16 @@ and expression_content =
|
|||||||
| E_matching of matching
|
| E_matching of matching
|
||||||
(* Record *)
|
(* Record *)
|
||||||
| E_record of expression label_map
|
| E_record of expression label_map
|
||||||
| E_record_accessor of accessor
|
| E_record_accessor of record_accessor
|
||||||
| E_record_update of update
|
| E_record_update of record_update
|
||||||
(* Advanced *)
|
(* Advanced *)
|
||||||
| E_ascription of ascription
|
| E_ascription of ascription
|
||||||
(* Sugar *)
|
(* Sugar *)
|
||||||
| E_sequence of sequence
|
| E_sequence of sequence
|
||||||
| E_skip
|
| E_skip
|
||||||
|
| E_tuple of expression list
|
||||||
|
| E_tuple_accessor of tuple_accessor
|
||||||
|
| E_tuple_update of tuple_update
|
||||||
(* Data Structures *)
|
(* Data Structures *)
|
||||||
| E_map of (expression * expression) list
|
| E_map of (expression * expression) list
|
||||||
| E_big_map of (expression * expression) list
|
| E_big_map of (expression * expression) list
|
||||||
@ -89,9 +106,10 @@ and let_in =
|
|||||||
|
|
||||||
and constructor = {constructor: constructor'; element: expression}
|
and constructor = {constructor: constructor'; element: expression}
|
||||||
|
|
||||||
and accessor = {record: expression; label: label}
|
and record_accessor = {record: expression; path: label}
|
||||||
|
and record_update = {record: expression; path: label ; update: expression}
|
||||||
|
|
||||||
|
|
||||||
and update = {record: expression; path: label ; update: expression}
|
|
||||||
|
|
||||||
and matching_expr = (expr,unit) matching_content
|
and matching_expr = (expr,unit) matching_content
|
||||||
and matching =
|
and matching =
|
||||||
@ -105,6 +123,9 @@ and sequence = {
|
|||||||
expr2: expression ;
|
expr2: expression ;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
and tuple_accessor = {tuple: expression; path: int}
|
||||||
|
and tuple_update = {tuple: expression; path: int ; update: expression}
|
||||||
|
|
||||||
and assign = {
|
and assign = {
|
||||||
variable : expression_variable;
|
variable : expression_variable;
|
||||||
access_path : access list;
|
access_path : access list;
|
||||||
|
@ -4,11 +4,41 @@ open Format
|
|||||||
open PP_helpers
|
open PP_helpers
|
||||||
|
|
||||||
include Stage_common.PP
|
include Stage_common.PP
|
||||||
include Ast_PP_type(Ast_sugar_parameter)
|
|
||||||
|
|
||||||
let expression_variable ppf (ev : expression_variable) : unit =
|
let expression_variable ppf (ev : expression_variable) : unit =
|
||||||
fprintf ppf "%a" Var.pp ev
|
fprintf ppf "%a" Var.pp ev
|
||||||
|
|
||||||
|
let rec type_expression' :
|
||||||
|
(formatter -> type_expression -> unit)
|
||||||
|
-> formatter
|
||||||
|
-> type_expression
|
||||||
|
-> unit =
|
||||||
|
fun f ppf te ->
|
||||||
|
match te.type_content with
|
||||||
|
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
|
||||||
|
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
|
||||||
|
| T_tuple t -> fprintf ppf "%a" (list_sep_d f) t
|
||||||
|
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
|
||||||
|
| T_variable tv -> type_variable ppf tv
|
||||||
|
| T_constant tc -> type_constant ppf tc
|
||||||
|
| T_operator to_ -> type_operator f ppf to_
|
||||||
|
|
||||||
|
and type_expression ppf (te : type_expression) : unit =
|
||||||
|
type_expression' type_expression ppf te
|
||||||
|
|
||||||
|
and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator -> unit =
|
||||||
|
fun f ppf to_ ->
|
||||||
|
let s =
|
||||||
|
match to_ with
|
||||||
|
| TC_option te -> Format.asprintf "option(%a)" f te
|
||||||
|
| TC_list te -> Format.asprintf "list(%a)" f te
|
||||||
|
| TC_set te -> Format.asprintf "set(%a)" f te
|
||||||
|
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
|
||||||
|
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
|
||||||
|
| TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
|
||||||
|
| TC_contract te -> Format.asprintf "Contract (%a)" f te
|
||||||
|
in
|
||||||
|
fprintf ppf "(TO_%s)" s
|
||||||
|
|
||||||
let rec expression ppf (e : expression) =
|
let rec expression ppf (e : expression) =
|
||||||
expression_content ppf e.expression_content
|
expression_content ppf e.expression_content
|
||||||
@ -28,7 +58,7 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
||||||
| E_record_accessor ra ->
|
| E_record_accessor ra ->
|
||||||
fprintf ppf "%a.%a" expression ra.record label ra.label
|
fprintf ppf "%a.%a" expression ra.record label ra.path
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
||||||
| E_map m ->
|
| E_map m ->
|
||||||
@ -69,6 +99,12 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation
|
fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation
|
||||||
| E_skip ->
|
| E_skip ->
|
||||||
fprintf ppf "skip"
|
fprintf ppf "skip"
|
||||||
|
| E_tuple t ->
|
||||||
|
fprintf ppf "%a" (list_sep_d expression) t
|
||||||
|
| E_tuple_accessor ta ->
|
||||||
|
fprintf ppf "%a.%d" expression ta.tuple ta.path
|
||||||
|
| E_tuple_update {tuple; path; update} ->
|
||||||
|
fprintf ppf "{ %a with { %d = %a } }" expression tuple path expression update
|
||||||
|
|
||||||
and option_type_name ppf
|
and option_type_name ppf
|
||||||
((n, ty_opt) : expression_variable * type_expression option) =
|
((n, ty_opt) : expression_variable * type_expression option) =
|
||||||
|
@ -19,7 +19,7 @@ module Errors = struct
|
|||||||
end
|
end
|
||||||
open Errors
|
open Errors
|
||||||
|
|
||||||
let make_t type_content = {type_content; type_meta = ()}
|
let make_t type_content = {type_content}
|
||||||
|
|
||||||
|
|
||||||
let tuple_to_record lst =
|
let tuple_to_record lst =
|
||||||
@ -112,6 +112,8 @@ let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NO
|
|||||||
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
||||||
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
||||||
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
||||||
|
let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b}
|
||||||
|
let e_record_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b
|
||||||
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
||||||
let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
|
let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
|
||||||
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut }
|
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut }
|
||||||
@ -127,6 +129,7 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
|
|||||||
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
|
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
|
||||||
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
|
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
|
||||||
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
|
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
|
||||||
|
let e_look_up ?loc a b : expression = make_expr ?loc @@ E_look_up (a,b)
|
||||||
|
|
||||||
let ez_match_variant (lst : ((string * string) * 'a) list) =
|
let ez_match_variant (lst : ((string * string) * 'a) list) =
|
||||||
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
|
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
|
||||||
@ -139,7 +142,7 @@ let e_record_ez ?loc (lst : (string * expr) list) : expression =
|
|||||||
let e_record ?loc map =
|
let e_record ?loc map =
|
||||||
let lst = Map.String.to_kv_list map in
|
let lst = Map.String.to_kv_list map in
|
||||||
e_record_ez ?loc lst
|
e_record_ez ?loc lst
|
||||||
let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b}
|
let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path= Label b}
|
||||||
|
|
||||||
let e_record_update ?loc record path update =
|
let e_record_update ?loc record path update =
|
||||||
let path = Label path in
|
let path = Label path in
|
||||||
@ -180,25 +183,18 @@ let e_lambda ?loc (binder : expression_variable)
|
|||||||
}
|
}
|
||||||
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
|
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
|
||||||
|
|
||||||
let get_e_accessor = fun t ->
|
let get_e_record_accessor = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record_accessor {record; label} -> ok (record , label)
|
| E_record_accessor {record; path} -> ok (record, path)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not a record accessor"
|
||||||
|
|
||||||
let assert_e_accessor = fun t ->
|
let assert_e_accessor = fun t ->
|
||||||
let%bind _ = get_e_accessor t in
|
let%bind _ = get_e_record_accessor t in
|
||||||
ok ()
|
ok ()
|
||||||
|
|
||||||
let get_e_pair = fun t ->
|
let get_e_pair = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record r -> (
|
| E_tuple [a ; b] -> ok (a , b)
|
||||||
let lst = LMap.to_kv_list r in
|
|
||||||
match lst with
|
|
||||||
| [(Label "O",a);(Label "1",b)]
|
|
||||||
| [(Label "1",b);(Label "0",a)] ->
|
|
||||||
ok (a , b)
|
|
||||||
| _ -> simple_fail "not a pair"
|
|
||||||
)
|
|
||||||
| _ -> simple_fail "not a pair"
|
| _ -> simple_fail "not a pair"
|
||||||
|
|
||||||
let get_e_list = fun t ->
|
let get_e_list = fun t ->
|
||||||
@ -206,29 +202,15 @@ let get_e_list = fun t ->
|
|||||||
| E_list lst -> ok lst
|
| E_list lst -> ok lst
|
||||||
| _ -> simple_fail "not a list"
|
| _ -> simple_fail "not a list"
|
||||||
|
|
||||||
let tuple_of_record (m: _ LMap.t) =
|
|
||||||
let aux i =
|
|
||||||
let opt = LMap.find_opt (Label (string_of_int i)) m in
|
|
||||||
Option.bind (fun opt -> Some (opt,i+1)) opt
|
|
||||||
in
|
|
||||||
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
|
|
||||||
|
|
||||||
let get_e_tuple = fun t ->
|
let get_e_tuple = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record r -> ok @@ tuple_of_record r
|
| E_tuple t -> ok @@ t
|
||||||
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
|
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
|
||||||
|
|
||||||
(* Same as get_e_pair *)
|
(* Same as get_e_pair *)
|
||||||
let extract_pair : expression -> (expression * expression) result = fun e ->
|
let extract_pair : expression -> (expression * expression) result = fun e ->
|
||||||
match e.expression_content with
|
match e.expression_content with
|
||||||
| E_record r -> (
|
| E_tuple [a;b] -> ok @@ (a,b)
|
||||||
let lst = LMap.to_kv_list r in
|
|
||||||
match lst with
|
|
||||||
| [(Label "O",a);(Label "1",b)]
|
|
||||||
| [(Label "1",b);(Label "0",a)] ->
|
|
||||||
ok (a , b)
|
|
||||||
| _ -> fail @@ bad_kind "pair" e.location
|
|
||||||
)
|
|
||||||
| _ -> fail @@ bad_kind "pair" e.location
|
| _ -> fail @@ bad_kind "pair" e.location
|
||||||
|
|
||||||
let extract_list : expression -> (expression list) result = fun e ->
|
let extract_list : expression -> (expression list) result = fun e ->
|
||||||
|
@ -80,6 +80,7 @@ val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option
|
|||||||
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
||||||
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
||||||
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
|
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
|
||||||
|
val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> expression
|
||||||
|
|
||||||
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
||||||
|
|
||||||
@ -90,9 +91,11 @@ val e_list : ?loc:Location.t -> expression list -> expression
|
|||||||
val e_set : ?loc:Location.t -> expression list -> expression
|
val e_set : ?loc:Location.t -> expression list -> expression
|
||||||
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
||||||
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
||||||
|
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
|
||||||
|
|
||||||
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
||||||
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
|
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
|
||||||
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
|
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
|
||||||
|
|
||||||
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
|
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
|
||||||
@ -109,9 +112,6 @@ val e_record_ez : ?loc:Location.t -> (string * expression) list -> expression
|
|||||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
val e_tuple : ?loc:Location.t -> expression list -> expression
|
val e_tuple : ?loc:Location.t -> expression list -> expression
|
||||||
val e_pair : ?loc:Location.t -> expression -> expression -> expression
|
val e_pair : ?loc:Location.t -> expression -> expression -> expression
|
||||||
(*
|
|
||||||
val get_e_accessor : expression' -> ( expression * access_path ) result
|
|
||||||
*)
|
|
||||||
|
|
||||||
val assert_e_accessor : expression_content -> unit result
|
val assert_e_accessor : expression_content -> unit result
|
||||||
|
|
||||||
|
@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
|
|||||||
| E_record_update _, _ ->
|
| E_record_update _, _ ->
|
||||||
simple_fail "comparing record update with other expression"
|
simple_fail "comparing record update with other expression"
|
||||||
|
|
||||||
|
| E_tuple lsta, E_tuple lstb -> (
|
||||||
|
let%bind lst =
|
||||||
|
generic_try (simple_error "tuples with different number of elements")
|
||||||
|
(fun () -> List.combine lsta lstb) in
|
||||||
|
let%bind _all = bind_list @@ List.map assert_value_eq lst in
|
||||||
|
ok ()
|
||||||
|
)
|
||||||
|
| E_tuple _, _ ->
|
||||||
|
simple_fail "comparing tuple with other expression"
|
||||||
|
|
||||||
|
| E_tuple_update uta, E_tuple_update utb ->
|
||||||
|
let _ =
|
||||||
|
generic_try (simple_error "Updating different tuple") @@
|
||||||
|
fun () -> assert_value_eq (uta.tuple, utb.tuple) in
|
||||||
|
let () = assert (uta.path == utb.path) in
|
||||||
|
let%bind () = assert_value_eq (uta.update,utb.update) in
|
||||||
|
ok ()
|
||||||
|
| E_tuple_update _, _ ->
|
||||||
|
simple_fail "comparing tuple update with other expression"
|
||||||
|
|
||||||
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
|
| (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")
|
let%bind lst = generic_try (simple_error "maps of different lengths")
|
||||||
(fun () ->
|
(fun () ->
|
||||||
@ -182,7 +202,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
|
|||||||
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
|
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
|
||||||
| (E_variable _, _) | (E_lambda _, _)
|
| (E_variable _, _) | (E_lambda _, _)
|
||||||
| (E_application _, _) | (E_let_in _, _)
|
| (E_application _, _) | (E_let_in _, _)
|
||||||
| (E_recursive _,_) | (E_record_accessor _, _)
|
| (E_recursive _,_)
|
||||||
|
| (E_record_accessor _, _) | (E_tuple_accessor _, _)
|
||||||
| (E_look_up _, _) | (E_matching _, _)
|
| (E_look_up _, _) | (E_matching _, _)
|
||||||
| (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value"
|
| (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value"
|
||||||
|
|
||||||
|
@ -2,17 +2,31 @@
|
|||||||
|
|
||||||
module Location = Simple_utils.Location
|
module Location = Simple_utils.Location
|
||||||
|
|
||||||
module Ast_sugar_parameter = struct
|
|
||||||
type type_meta = unit
|
|
||||||
end
|
|
||||||
|
|
||||||
include Stage_common.Types
|
include Stage_common.Types
|
||||||
|
|
||||||
(*include Ast_generic_type(Ast_core_parameter)
|
type type_content =
|
||||||
*)
|
| T_sum of type_expression constructor_map
|
||||||
include Ast_generic_type (Ast_sugar_parameter)
|
| T_record of type_expression label_map
|
||||||
|
| T_tuple of type_expression list
|
||||||
|
| T_arrow of arrow
|
||||||
|
| T_variable of type_variable
|
||||||
|
| T_constant of type_constant
|
||||||
|
| T_operator of type_operator
|
||||||
|
|
||||||
|
and arrow = {type1: type_expression; type2: type_expression}
|
||||||
|
|
||||||
|
and type_operator =
|
||||||
|
| TC_contract of type_expression
|
||||||
|
| TC_option of type_expression
|
||||||
|
| TC_list of type_expression
|
||||||
|
| TC_set of type_expression
|
||||||
|
| TC_map of type_expression * type_expression
|
||||||
|
| TC_big_map of type_expression * type_expression
|
||||||
|
| TC_arrow of type_expression * type_expression
|
||||||
|
|
||||||
|
and type_expression = {type_content: type_content}
|
||||||
|
|
||||||
|
|
||||||
type inline = bool
|
|
||||||
type program = declaration Location.wrap list
|
type program = declaration Location.wrap list
|
||||||
and declaration =
|
and declaration =
|
||||||
| Declaration_type of (type_variable * type_expression)
|
| Declaration_type of (type_variable * type_expression)
|
||||||
@ -22,7 +36,7 @@ and declaration =
|
|||||||
* an optional type annotation
|
* an optional type annotation
|
||||||
* a boolean indicating whether it should be inlined
|
* a boolean indicating whether it should be inlined
|
||||||
* an expression *)
|
* an expression *)
|
||||||
| Declaration_constant of (expression_variable * type_expression option * inline * expression)
|
| Declaration_constant of (expression_variable * type_expression option * bool * expression)
|
||||||
|
|
||||||
(* | Macro_declaration of macro_declaration *)
|
(* | Macro_declaration of macro_declaration *)
|
||||||
and expression = {expression_content: expression_content; location: Location.t}
|
and expression = {expression_content: expression_content; location: Location.t}
|
||||||
@ -41,13 +55,16 @@ and expression_content =
|
|||||||
| E_matching of matching
|
| E_matching of matching
|
||||||
(* Record *)
|
(* Record *)
|
||||||
| E_record of expression label_map
|
| E_record of expression label_map
|
||||||
| E_record_accessor of accessor
|
| E_record_accessor of record_accessor
|
||||||
| E_record_update of update
|
| E_record_update of record_update
|
||||||
(* Advanced *)
|
(* Advanced *)
|
||||||
| E_ascription of ascription
|
| E_ascription of ascription
|
||||||
(* Sugar *)
|
(* Sugar *)
|
||||||
| E_sequence of sequence
|
| E_sequence of sequence
|
||||||
| E_skip
|
| E_skip
|
||||||
|
| E_tuple of expression list
|
||||||
|
| E_tuple_accessor of tuple_accessor
|
||||||
|
| E_tuple_update of tuple_update
|
||||||
(* Data Structures *)
|
(* Data Structures *)
|
||||||
| E_map of (expression * expression) list
|
| E_map of (expression * expression) list
|
||||||
| E_big_map of (expression * expression) list
|
| E_big_map of (expression * expression) list
|
||||||
@ -86,9 +103,8 @@ and let_in = {
|
|||||||
|
|
||||||
and constructor = {constructor: constructor'; element: expression}
|
and constructor = {constructor: constructor'; element: expression}
|
||||||
|
|
||||||
and accessor = {record: expression; label: label}
|
and record_accessor = {record: expression; path: label}
|
||||||
|
and record_update = {record: expression; path: label ; update: expression}
|
||||||
and update = {record: expression; path: label ; update: expression}
|
|
||||||
|
|
||||||
and matching_expr = (expr,unit) matching_content
|
and matching_expr = (expr,unit) matching_content
|
||||||
and matching =
|
and matching =
|
||||||
@ -102,6 +118,9 @@ and sequence = {
|
|||||||
expr2: expression ;
|
expr2: expression ;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
and tuple_accessor = {tuple: expression; path: int}
|
||||||
|
and tuple_update = {tuple: expression; path: int ; update: expression}
|
||||||
|
|
||||||
and environment_element_definition =
|
and environment_element_definition =
|
||||||
| ED_binder
|
| ED_binder
|
||||||
| ED_declaration of (expression * free_variables)
|
| ED_declaration of (expression * free_variables)
|
||||||
|
@ -28,7 +28,7 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
||||||
| E_record_accessor ra ->
|
| E_record_accessor ra ->
|
||||||
fprintf ppf "%a.%a" expression ra.record label ra.label
|
fprintf ppf "%a.%a" expression ra.record label ra.path
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
||||||
| E_lambda {binder; input_type; output_type; result} ->
|
| E_lambda {binder; input_type; output_type; result} ->
|
||||||
|
@ -114,8 +114,8 @@ let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_na
|
|||||||
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
||||||
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
||||||
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
||||||
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b}
|
let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b}
|
||||||
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
let e_record_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b
|
||||||
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
||||||
let e_let_in ?loc (binder, ascr) inline rhs let_result =
|
let e_let_in ?loc (binder, ascr) inline rhs let_result =
|
||||||
make_expr ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
|
make_expr ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
|
||||||
@ -139,7 +139,7 @@ let e_record ?loc map =
|
|||||||
let lst = Map.String.to_kv_list map in
|
let lst = Map.String.to_kv_list map in
|
||||||
e_record_ez ?loc lst
|
e_record_ez ?loc lst
|
||||||
|
|
||||||
let e_update ?loc record path update =
|
let e_record_update ?loc record path update =
|
||||||
let path = Label path in
|
let path = Label path in
|
||||||
make_expr ?loc @@ E_record_update {record; path; update}
|
make_expr ?loc @@ E_record_update {record; path; update}
|
||||||
|
|
||||||
@ -178,20 +178,20 @@ let e_assign_with_let ?loc var access_path expr =
|
|||||||
| lst ->
|
| lst ->
|
||||||
let rec aux path record= match path with
|
let rec aux path record= match path with
|
||||||
| [] -> failwith "acces_path cannot be empty"
|
| [] -> failwith "acces_path cannot be empty"
|
||||||
| [e] -> e_update ?loc record e expr
|
| [e] -> e_record_update ?loc record e expr
|
||||||
| elem::tail ->
|
| elem::tail ->
|
||||||
let next_record = e_accessor record elem in
|
let next_record = e_record_accessor record elem in
|
||||||
e_update ?loc record elem (aux tail next_record )
|
e_record_update ?loc record elem (aux tail next_record )
|
||||||
in
|
in
|
||||||
(var, None), true, (aux lst (e_variable var)), false
|
(var, None), true, (aux lst (e_variable var)), false
|
||||||
|
|
||||||
let get_e_accessor = fun t ->
|
let get_e_record_accessor = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record_accessor {record; label} -> ok (record , label)
|
| E_record_accessor {record; path} -> ok (record, path)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not an accessor"
|
||||||
|
|
||||||
let assert_e_accessor = fun t ->
|
let assert_e_record_accessor = fun t ->
|
||||||
let%bind _ = get_e_accessor t in
|
let%bind _ = get_e_record_accessor t in
|
||||||
ok ()
|
ok ()
|
||||||
|
|
||||||
let get_e_pair = fun t ->
|
let get_e_pair = fun t ->
|
||||||
@ -218,16 +218,9 @@ let get_e_list = fun t ->
|
|||||||
in
|
in
|
||||||
aux t
|
aux t
|
||||||
|
|
||||||
let tuple_of_record (m: _ LMap.t) =
|
|
||||||
let aux i =
|
|
||||||
let opt = LMap.find_opt (Label (string_of_int i)) m in
|
|
||||||
Option.bind (fun opt -> Some (opt,i+1)) opt
|
|
||||||
in
|
|
||||||
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
|
|
||||||
|
|
||||||
let get_e_tuple = fun t ->
|
let get_e_tuple = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record r -> ok @@ tuple_of_record r
|
| E_record r -> ok @@ List.map snd @@ Stage_common.Helpers.tuple_of_record r
|
||||||
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
|
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
|
||||||
|
|
||||||
(* Same as get_e_pair *)
|
(* Same as get_e_pair *)
|
||||||
|
@ -76,8 +76,8 @@ val e_pair : ?loc:Location.t -> expression -> expression -> expression
|
|||||||
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
||||||
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
||||||
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
val e_accessor : ?loc:Location.t -> expression -> string -> expression
|
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
|
||||||
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
|
val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> expression
|
||||||
val e_variable : ?loc:Location.t -> expression_variable -> expression
|
val e_variable : ?loc:Location.t -> expression_variable -> expression
|
||||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
|
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
|
||||||
@ -95,14 +95,14 @@ val e_typed_none : ?loc:Location.t -> type_expression -> expression
|
|||||||
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
|
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
|
||||||
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
|
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
|
||||||
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
||||||
val e_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
||||||
val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)
|
val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)
|
||||||
|
|
||||||
(*
|
(*
|
||||||
val get_e_accessor : expression' -> ( expression * access_path ) result
|
val get_e_accessor : expression' -> ( expression * access_path ) result
|
||||||
*)
|
*)
|
||||||
|
|
||||||
val assert_e_accessor : expression_content -> unit result
|
val assert_e_record_accessor : expression_content -> unit result
|
||||||
|
|
||||||
val get_e_pair : expression_content -> ( expression * expression ) result
|
val get_e_pair : expression_content -> ( expression * expression ) result
|
||||||
|
|
||||||
|
@ -41,8 +41,8 @@ and expression_content =
|
|||||||
| E_matching of matching
|
| E_matching of matching
|
||||||
(* Record *)
|
(* Record *)
|
||||||
| E_record of expression label_map
|
| E_record of expression label_map
|
||||||
| E_record_accessor of accessor
|
| E_record_accessor of record_accessor
|
||||||
| E_record_update of update
|
| E_record_update of record_update
|
||||||
(* Advanced *)
|
(* Advanced *)
|
||||||
| E_ascription of ascription
|
| E_ascription of ascription
|
||||||
|
|
||||||
@ -75,9 +75,8 @@ and let_in =
|
|||||||
|
|
||||||
and constructor = {constructor: constructor'; element: expression}
|
and constructor = {constructor: constructor'; element: expression}
|
||||||
|
|
||||||
and accessor = {record: expression; label: label}
|
and record_accessor = {record: expression; path: label}
|
||||||
|
and record_update = {record: expression; path: label ; update: expression}
|
||||||
and update = {record: expression; path: label ; update: expression}
|
|
||||||
|
|
||||||
and matching_expr = (expr,unit) matching_content
|
and matching_expr = (expr,unit) matching_content
|
||||||
and matching =
|
and matching =
|
||||||
|
@ -29,7 +29,7 @@ and expression_content ppf (ec: expression_content) =
|
|||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
||||||
| E_record_accessor ra ->
|
| E_record_accessor ra ->
|
||||||
fprintf ppf "%a.%a" expression ra.record label ra.label
|
fprintf ppf "%a.%a" expression ra.record label ra.path
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
||||||
| E_lambda {binder; result} ->
|
| E_lambda {binder; result} ->
|
||||||
|
@ -335,7 +335,7 @@ let get_a_bool (t:expression) =
|
|||||||
|
|
||||||
let get_a_record_accessor = fun t ->
|
let get_a_record_accessor = fun t ->
|
||||||
match t.expression_content with
|
match t.expression_content with
|
||||||
| E_record_accessor {record ; label} -> ok (record , label)
|
| E_record_accessor {record; path} -> ok (record, path)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not an accessor"
|
||||||
|
|
||||||
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
|
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
|
||||||
|
@ -47,8 +47,8 @@ and expression_content =
|
|||||||
| E_matching of matching
|
| E_matching of matching
|
||||||
(* Record *)
|
(* Record *)
|
||||||
| E_record of expression label_map
|
| E_record of expression label_map
|
||||||
| E_record_accessor of accessor
|
| E_record_accessor of record_accessor
|
||||||
| E_record_update of update
|
| E_record_update of record_update
|
||||||
|
|
||||||
and constant =
|
and constant =
|
||||||
{ cons_name: constant'
|
{ cons_name: constant'
|
||||||
@ -84,12 +84,12 @@ and constructor = {
|
|||||||
element: expression ;
|
element: expression ;
|
||||||
}
|
}
|
||||||
|
|
||||||
and accessor = {
|
and record_accessor = {
|
||||||
record: expression ;
|
record: expression ;
|
||||||
label: label ;
|
path: label ;
|
||||||
}
|
}
|
||||||
|
|
||||||
and update = {
|
and record_update = {
|
||||||
record: expression ;
|
record: expression ;
|
||||||
path: label ;
|
path: label ;
|
||||||
update: expression ;
|
update: expression ;
|
||||||
|
@ -16,15 +16,14 @@ let cmap_sep value sep ppf m =
|
|||||||
|
|
||||||
let record_sep value sep ppf (m : 'a label_map) =
|
let record_sep value sep ppf (m : 'a label_map) =
|
||||||
let lst = LMap.to_kv_list m in
|
let lst = LMap.to_kv_list m in
|
||||||
let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
|
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
|
||||||
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in
|
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in
|
||||||
fprintf ppf "%a" (list_sep new_pp sep) lst
|
fprintf ppf "%a" (list_sep new_pp sep) lst
|
||||||
|
|
||||||
let tuple_sep value sep ppf m =
|
let tuple_sep value sep ppf m =
|
||||||
assert (Helpers.is_tuple_lmap m);
|
assert (Helpers.is_tuple_lmap m);
|
||||||
let lst = LMap.to_kv_list m in
|
let lst = Helpers.tuple_of_record m in
|
||||||
let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
|
let new_pp ppf (_, v) = fprintf ppf "%a" value v in
|
||||||
let new_pp ppf (_k, v) = fprintf ppf "%a" value v in
|
|
||||||
fprintf ppf "%a" (list_sep new_pp sep) lst
|
fprintf ppf "%a" (list_sep new_pp sep) lst
|
||||||
|
|
||||||
(* Prints records which only contain the consecutive fields
|
(* Prints records which only contain the consecutive fields
|
||||||
@ -156,43 +155,50 @@ let constant ppf : constant' -> unit = function
|
|||||||
|
|
||||||
let literal ppf (l : literal) =
|
let literal ppf (l : literal) =
|
||||||
match l with
|
match l with
|
||||||
| Literal_unit ->
|
| Literal_unit -> fprintf ppf "unit"
|
||||||
fprintf ppf "unit"
|
| Literal_void -> fprintf ppf "void"
|
||||||
| Literal_void ->
|
| Literal_bool b -> fprintf ppf "%b" b
|
||||||
fprintf ppf "void"
|
| Literal_int n -> fprintf ppf "%d" n
|
||||||
| Literal_bool b ->
|
| Literal_nat n -> fprintf ppf "+%d" n
|
||||||
fprintf ppf "%b" b
|
| Literal_timestamp n -> fprintf ppf "+%d" n
|
||||||
| Literal_int n ->
|
| Literal_mutez n -> fprintf ppf "%dmutez" n
|
||||||
fprintf ppf "%d" n
|
| Literal_string s -> fprintf ppf "%S" s
|
||||||
| Literal_nat n ->
|
| Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
|
||||||
fprintf ppf "+%d" n
|
| Literal_address s -> fprintf ppf "@%S" s
|
||||||
| Literal_timestamp n ->
|
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
|
||||||
fprintf ppf "+%d" n
|
| Literal_key s -> fprintf ppf "key %s" s
|
||||||
| Literal_mutez n ->
|
| Literal_key_hash s -> fprintf ppf "key_hash %s" s
|
||||||
fprintf ppf "%dmutez" n
|
| Literal_signature s -> fprintf ppf "Signature %s" s
|
||||||
| Literal_string s ->
|
| Literal_chain_id s -> fprintf ppf "Chain_id %s" s
|
||||||
fprintf ppf "%S" s
|
|
||||||
| Literal_bytes b ->
|
let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
|
||||||
fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
|
|
||||||
| Literal_address s ->
|
and type_constant ppf (tc : type_constant) : unit =
|
||||||
fprintf ppf "@%S" s
|
let s =
|
||||||
| Literal_operation _ ->
|
match tc with
|
||||||
fprintf ppf "Operation(...bytes)"
|
| TC_unit -> "unit"
|
||||||
| Literal_key s ->
|
| TC_string -> "string"
|
||||||
fprintf ppf "key %s" s
|
| TC_bytes -> "bytes"
|
||||||
| Literal_key_hash s ->
|
| TC_nat -> "nat"
|
||||||
fprintf ppf "key_hash %s" s
|
| TC_int -> "int"
|
||||||
| Literal_signature s ->
|
| TC_mutez -> "mutez"
|
||||||
fprintf ppf "Signature %s" s
|
| TC_bool -> "bool"
|
||||||
| Literal_chain_id s ->
|
| TC_operation -> "operation"
|
||||||
fprintf ppf "Chain_id %s" s
|
| TC_address -> "address"
|
||||||
|
| TC_key -> "key"
|
||||||
|
| TC_key_hash -> "key_hash"
|
||||||
|
| TC_signature -> "signature"
|
||||||
|
| TC_timestamp -> "timestamp"
|
||||||
|
| TC_chain_id -> "chain_id"
|
||||||
|
| TC_void -> "void"
|
||||||
|
in
|
||||||
|
fprintf ppf "%s" s
|
||||||
|
|
||||||
module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
||||||
module Agt=Ast_generic_type(PARAMETER)
|
module Agt=Ast_generic_type(PARAMETER)
|
||||||
open Agt
|
open Agt
|
||||||
open Format
|
open Format
|
||||||
|
|
||||||
let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
|
|
||||||
|
|
||||||
let rec type_expression' :
|
let rec type_expression' :
|
||||||
(formatter -> type_expression -> unit)
|
(formatter -> type_expression -> unit)
|
||||||
-> formatter
|
-> formatter
|
||||||
@ -200,58 +206,16 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
|||||||
-> unit =
|
-> unit =
|
||||||
fun f ppf te ->
|
fun f ppf te ->
|
||||||
match te.type_content with
|
match te.type_content with
|
||||||
| T_sum m ->
|
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
|
||||||
fprintf ppf "sum[%a]" (cmap_sep_d f) m
|
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
|
||||||
| T_record m ->
|
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_type f) m
|
| T_variable tv -> type_variable ppf tv
|
||||||
| T_arrow a ->
|
| T_constant tc -> type_constant ppf tc
|
||||||
fprintf ppf "%a -> %a" f a.type1 f a.type2
|
| T_operator to_ -> type_operator f ppf to_
|
||||||
| T_variable tv ->
|
|
||||||
type_variable ppf tv
|
|
||||||
| T_constant tc ->
|
|
||||||
type_constant ppf tc
|
|
||||||
| T_operator to_ ->
|
|
||||||
type_operator f ppf to_
|
|
||||||
|
|
||||||
and type_expression ppf (te : type_expression) : unit =
|
and type_expression ppf (te : type_expression) : unit =
|
||||||
type_expression' type_expression ppf te
|
type_expression' type_expression ppf te
|
||||||
|
|
||||||
and type_constant ppf (tc : type_constant) : unit =
|
|
||||||
let s =
|
|
||||||
match tc with
|
|
||||||
| TC_unit ->
|
|
||||||
"unit"
|
|
||||||
| TC_string ->
|
|
||||||
"string"
|
|
||||||
| TC_bytes ->
|
|
||||||
"bytes"
|
|
||||||
| TC_nat ->
|
|
||||||
"nat"
|
|
||||||
| TC_int ->
|
|
||||||
"int"
|
|
||||||
| TC_mutez ->
|
|
||||||
"mutez"
|
|
||||||
| TC_bool ->
|
|
||||||
"bool"
|
|
||||||
| TC_operation ->
|
|
||||||
"operation"
|
|
||||||
| TC_address ->
|
|
||||||
"address"
|
|
||||||
| TC_key ->
|
|
||||||
"key"
|
|
||||||
| TC_key_hash ->
|
|
||||||
"key_hash"
|
|
||||||
| TC_signature ->
|
|
||||||
"signature"
|
|
||||||
| TC_timestamp ->
|
|
||||||
"timestamp"
|
|
||||||
| TC_chain_id ->
|
|
||||||
"chain_id"
|
|
||||||
| TC_void ->
|
|
||||||
"void"
|
|
||||||
in
|
|
||||||
fprintf ppf "%s" s
|
|
||||||
|
|
||||||
and type_operator :
|
and type_operator :
|
||||||
(formatter -> type_expression -> unit)
|
(formatter -> type_expression -> unit)
|
||||||
-> formatter
|
-> formatter
|
||||||
|
@ -46,3 +46,23 @@ let get_pair m =
|
|||||||
match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with
|
match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with
|
||||||
| Some e1, Some e2 -> ok (e1,e2)
|
| Some e1, Some e2 -> ok (e1,e2)
|
||||||
| _ -> simple_fail "not a pair"
|
| _ -> simple_fail "not a pair"
|
||||||
|
|
||||||
|
let tuple_of_record (m: _ LMap.t) =
|
||||||
|
let aux i =
|
||||||
|
let label = Label (string_of_int i) in
|
||||||
|
let opt = LMap.find_opt (label) m in
|
||||||
|
Option.bind (fun opt -> Some ((label,opt),i+1)) opt
|
||||||
|
in
|
||||||
|
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
|
||||||
|
|
||||||
|
let list_of_record_or_tuple (m: _ LMap.t) =
|
||||||
|
if (is_tuple_lmap m) then
|
||||||
|
List.map snd @@ tuple_of_record m
|
||||||
|
else
|
||||||
|
List.rev @@ LMap.to_list m
|
||||||
|
|
||||||
|
let kv_list_of_record_or_tuple (m: _ LMap.t) =
|
||||||
|
if (is_tuple_lmap m) then
|
||||||
|
tuple_of_record m
|
||||||
|
else
|
||||||
|
List.rev @@ LMap.to_kv_list m
|
||||||
|
@ -1,3 +1,5 @@
|
|||||||
|
open Types
|
||||||
|
|
||||||
val bind_lmap :
|
val bind_lmap :
|
||||||
('a * 'b list, 'c) result Types.label_map ->
|
('a * 'b list, 'c) result Types.label_map ->
|
||||||
('a Types.label_map * 'b list, 'c) result
|
('a Types.label_map * 'b list, 'c) result
|
||||||
@ -19,6 +21,9 @@ val is_tuple_lmap : 'a Types.label_map -> bool
|
|||||||
val get_pair :
|
val get_pair :
|
||||||
'a Types.label_map ->
|
'a Types.label_map ->
|
||||||
(('a * 'a) * 'b list, unit -> Trace.error) result
|
(('a * 'a) * 'b list, unit -> Trace.error) result
|
||||||
|
val tuple_of_record : 'a LMap.t -> (label * 'a) list
|
||||||
|
val list_of_record_or_tuple : 'a LMap.t -> 'a list
|
||||||
|
val kv_list_of_record_or_tuple : 'a LMap.t -> (label * 'a) list
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -136,7 +136,7 @@ module Substitution = struct
|
|||||||
and s_matching_expr : T.matching_expr w = fun ~substs _ ->
|
and s_matching_expr : T.matching_expr w = fun ~substs _ ->
|
||||||
let _TODO = substs in
|
let _TODO = substs in
|
||||||
failwith "TODO: subst: unimplemented case s_matching"
|
failwith "TODO: subst: unimplemented case s_matching"
|
||||||
and s_accessor : T.accessor w = fun ~substs _ ->
|
and s_accessor : T.record_accessor w = fun ~substs _ ->
|
||||||
let _TODO = substs in
|
let _TODO = substs in
|
||||||
failwith "TODO: subst: unimplemented case s_access_path"
|
failwith "TODO: subst: unimplemented case s_access_path"
|
||||||
|
|
||||||
@ -182,10 +182,10 @@ module Substitution = struct
|
|||||||
* let val_ = s_expression ~v ~expr val_ in
|
* let val_ = s_expression ~v ~expr val_ in
|
||||||
* ok @@ (key , val_)) aemap in
|
* ok @@ (key , val_)) aemap in
|
||||||
* ok @@ T.E_record aemap *)
|
* ok @@ T.E_record aemap *)
|
||||||
| T.E_record_accessor {record=e;label} ->
|
| T.E_record_accessor {record=e;path} ->
|
||||||
let%bind record = s_expression ~substs e in
|
let%bind record = s_expression ~substs e in
|
||||||
let%bind label = s_label ~substs label in
|
let%bind path = s_label ~substs path in
|
||||||
ok @@ T.E_record_accessor {record;label}
|
ok @@ T.E_record_accessor {record;path}
|
||||||
| T.E_record_update {record;path;update}->
|
| T.E_record_update {record;path;update}->
|
||||||
let%bind record = s_expression ~substs record in
|
let%bind record = s_expression ~substs record in
|
||||||
let%bind update = s_expression ~substs update in
|
let%bind update = s_expression ~substs update in
|
||||||
|
@ -13,6 +13,11 @@ const fb : foobar = (0,0)
|
|||||||
|
|
||||||
function projection (const tpl : foobar) : int is tpl.0 + tpl.1
|
function projection (const tpl : foobar) : int is tpl.0 + tpl.1
|
||||||
|
|
||||||
type big_tuple is int * int * int * int * int
|
type big_tuple is int * int * int * int * int * int * int * int * int * int * int * int
|
||||||
|
|
||||||
const br : big_tuple = (23, 23, 23, 23, 23)
|
const br : big_tuple = (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
|
||||||
|
|
||||||
|
function update (const tpl : big_tuple) : big_tuple is
|
||||||
|
block {
|
||||||
|
tpl.11 := 2048
|
||||||
|
} with tpl
|
||||||
|
@ -876,9 +876,14 @@ let tuple () : unit result =
|
|||||||
expect_eq_n program "modify_abc" make_input make_expected
|
expect_eq_n program "modify_abc" make_input make_expected
|
||||||
in
|
in
|
||||||
let%bind () =
|
let%bind () =
|
||||||
let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in
|
let expected = ez [0 ; 1 ; 2 ; 3 ; 4; 5; 6; 7; 8; 9; 10; 11] in
|
||||||
expect_eq_evaluate program "br" expected
|
expect_eq_evaluate program "br" expected
|
||||||
in
|
in
|
||||||
|
let%bind () =
|
||||||
|
let make_input = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; n] in
|
||||||
|
let make_expected = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; 2048] in
|
||||||
|
expect_eq_n program "update" make_input make_expected
|
||||||
|
in
|
||||||
ok ()
|
ok ()
|
||||||
|
|
||||||
let tuple_mligo () : unit result =
|
let tuple_mligo () : unit result =
|
||||||
|
Loading…
Reference in New Issue
Block a user