fix unsupported deep_map assignements and remove. add tests
This commit is contained in:
parent
8dfb2a967f
commit
d59cd771c9
@ -109,17 +109,6 @@ module Errors = struct
|
|||||||
] in
|
] in
|
||||||
error ~data title message
|
error ~data title message
|
||||||
|
|
||||||
let unsupported_deep_map_assign v =
|
|
||||||
let title () = "map assignments" in
|
|
||||||
let message () =
|
|
||||||
Format.asprintf "assignments to embedded maps are not \
|
|
||||||
supported yet" in
|
|
||||||
let data = [
|
|
||||||
("lhs_loc",
|
|
||||||
fun () -> Format.asprintf "%a" Location.pp_lift @@ v.Region.region)
|
|
||||||
] in
|
|
||||||
error ~data title message
|
|
||||||
|
|
||||||
let unsupported_empty_record_patch record_expr =
|
let unsupported_empty_record_patch record_expr =
|
||||||
let title () = "empty record patch" in
|
let title () = "empty record patch" in
|
||||||
let message () =
|
let message () =
|
||||||
@ -152,18 +141,6 @@ module Errors = struct
|
|||||||
] in
|
] in
|
||||||
error ~data title message
|
error ~data title message
|
||||||
|
|
||||||
let unsupported_deep_map_rm path =
|
|
||||||
let title () = "binding removals" in
|
|
||||||
let message () =
|
|
||||||
Format.asprintf "removal of bindings from embedded maps \
|
|
||||||
are not supported yet" in
|
|
||||||
let data = [
|
|
||||||
("path_loc",
|
|
||||||
fun () -> Format.asprintf "%a" Location.pp_lift @@ path.Region.region)
|
|
||||||
] in
|
|
||||||
error ~data title message
|
|
||||||
|
|
||||||
|
|
||||||
(* let unsupported_set_removal remove =
|
(* let unsupported_set_removal remove =
|
||||||
let title () = "set removals" in
|
let title () = "set removals" in
|
||||||
let message () =
|
let message () =
|
||||||
@ -791,13 +768,17 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
|
|||||||
)
|
)
|
||||||
| MapPath v -> (
|
| MapPath v -> (
|
||||||
let v' = v.value in
|
let v' = v.value in
|
||||||
let%bind name = match v'.path with
|
let%bind (varname,map,path) = match v'.path with
|
||||||
| Name name -> ok name
|
| Name name -> ok (name.value , e_variable name.value, [])
|
||||||
| _ -> fail @@ unsupported_deep_map_assign v in
|
| Path p ->
|
||||||
|
let expr = e_variable p.value.struct_name.value in
|
||||||
|
let (_,p') = simpl_path v'.path in
|
||||||
|
let accessor = e_accessor expr p' in
|
||||||
|
ok @@ (p.value.struct_name.value , accessor , p')
|
||||||
|
in
|
||||||
let%bind key_expr = simpl_expression v'.index.value.inside in
|
let%bind key_expr = simpl_expression v'.index.value.inside in
|
||||||
let old_expr = e_variable name.value in
|
let expr' = e_map_add key_expr value_expr map in
|
||||||
let expr' = e_map_add key_expr value_expr old_expr in
|
return_statement @@ e_assign ~loc varname path expr'
|
||||||
return_statement @@ e_assign ~loc name.value [] expr'
|
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
| CaseInstr c -> (
|
| CaseInstr c -> (
|
||||||
@ -844,12 +825,17 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
|
|||||||
| MapRemove r -> (
|
| MapRemove r -> (
|
||||||
let (v , loc) = r_split r in
|
let (v , loc) = r_split r in
|
||||||
let key = v.key in
|
let key = v.key in
|
||||||
let%bind map = match v.map with
|
let%bind (varname,map,path) = match v.map with
|
||||||
| Name v -> ok v.value
|
| Name v -> ok (v.value , e_variable v.value , [])
|
||||||
| Path path -> fail @@ unsupported_deep_map_rm path in
|
| Path p ->
|
||||||
|
let expr = e_variable p.value.struct_name.value in
|
||||||
|
let (_,p') = simpl_path v.map in
|
||||||
|
let accessor = e_accessor expr p' in
|
||||||
|
ok @@ (p.value.struct_name.value , accessor , p')
|
||||||
|
in
|
||||||
let%bind key' = simpl_expression key in
|
let%bind key' = simpl_expression key in
|
||||||
let expr = e_constant ~loc "MAP_REMOVE" [key' ; e_variable map] in
|
let expr = e_constant ~loc "MAP_REMOVE" [key' ; map] in
|
||||||
return_statement @@ e_assign ~loc map [] expr
|
return_statement @@ e_assign ~loc varname path expr
|
||||||
)
|
)
|
||||||
| SetRemove r -> (
|
| SetRemove r -> (
|
||||||
let (set_rm, loc) = r_split r in
|
let (set_rm, loc) = r_split r in
|
||||||
|
@ -54,3 +54,10 @@ function map_op (const m : foobar) : foobar is
|
|||||||
function fold_op (const m : foobar) : int is
|
function fold_op (const m : foobar) : int is
|
||||||
function aggregate (const i : int ; const j : (int * int)) : int is block { skip } with i + j.0 + j.1 ;
|
function aggregate (const i : int ; const j : (int * int)) : int is block { skip } with i + j.0 + j.1 ;
|
||||||
block { skip } with map_fold(m , 10 , aggregate)
|
block { skip } with map_fold(m , 10 , aggregate)
|
||||||
|
|
||||||
|
function deep_op (var m : foobar) : foobar is
|
||||||
|
var coco : (int*foobar) := (0, m);
|
||||||
|
block {
|
||||||
|
remove 42 from map coco.1 ;
|
||||||
|
coco.1[32] := 16 ;
|
||||||
|
} with coco.1
|
@ -29,3 +29,9 @@ let map_op (m : foobar) : foobar =
|
|||||||
let fold_op (m : foobar) : foobar =
|
let fold_op (m : foobar) : foobar =
|
||||||
let aggregate = fun (i : int) (j : (int * int)) -> i + j.(0) + j.(1) in
|
let aggregate = fun (i : int) (j : (int * int)) -> i + j.(0) + j.(1) in
|
||||||
Map.fold m 10 aggregate
|
Map.fold m 10 aggregate
|
||||||
|
|
||||||
|
let deep_op (m : foobar) : foobar =
|
||||||
|
let coco = (0,m) in
|
||||||
|
let coco = (0 , Map.remove 42 coco.(1)) in
|
||||||
|
let coco = (0 , Map.update 32 (Some 16) coco.(1)) in
|
||||||
|
coco.(1)
|
@ -456,6 +456,11 @@ let map_ type_f path : unit result =
|
|||||||
let expected = e_int 76 in
|
let expected = e_int 76 in
|
||||||
expect_eq program "fold_op" input expected
|
expect_eq program "fold_op" input expected
|
||||||
in
|
in
|
||||||
|
let%bind () =
|
||||||
|
let input = ez [(2 , 20) ; (42 , 10)] in
|
||||||
|
let expected = ez [(2 , 20) ; (32 , 16) ] in
|
||||||
|
expect_eq program "deep_op" input expected
|
||||||
|
in
|
||||||
ok ()
|
ok ()
|
||||||
|
|
||||||
let big_map_ type_f path : unit result =
|
let big_map_ type_f path : unit result =
|
||||||
|
Loading…
Reference in New Issue
Block a user