Add rough draft of set patch functionality
This commit is contained in:
parent
8dfb2a967f
commit
2f60c85aa8
@ -141,7 +141,7 @@ module Errors = struct
|
|||||||
] in
|
] in
|
||||||
error ~data title message
|
error ~data title message
|
||||||
|
|
||||||
let unsupported_set_patches patch =
|
(* let unsupported_set_patches patch =
|
||||||
let title () = "set patches" in
|
let title () = "set patches" in
|
||||||
let message () =
|
let message () =
|
||||||
Format.asprintf "set patches (a.k.a. functional updates) are \
|
Format.asprintf "set patches (a.k.a. functional updates) are \
|
||||||
@ -150,7 +150,7 @@ module Errors = struct
|
|||||||
("patch_loc",
|
("patch_loc",
|
||||||
fun () -> Format.asprintf "%a" Location.pp_lift @@ patch.Region.region)
|
fun () -> Format.asprintf "%a" Location.pp_lift @@ patch.Region.region)
|
||||||
] in
|
] in
|
||||||
error ~data title message
|
error ~data title message *)
|
||||||
|
|
||||||
let unsupported_deep_map_rm path =
|
let unsupported_deep_map_rm path =
|
||||||
let title () = "binding removals" in
|
let title () = "binding removals" in
|
||||||
@ -163,18 +163,6 @@ module Errors = struct
|
|||||||
] in
|
] in
|
||||||
error ~data title message
|
error ~data title message
|
||||||
|
|
||||||
|
|
||||||
(* let unsupported_set_removal remove =
|
|
||||||
let title () = "set removals" in
|
|
||||||
let message () =
|
|
||||||
Format.asprintf "removal of elements in a set is not \
|
|
||||||
supported yet" in
|
|
||||||
let data = [
|
|
||||||
("removal_loc",
|
|
||||||
fun () -> Format.asprintf "%a" Location.pp_lift @@ remove.Region.region)
|
|
||||||
] in
|
|
||||||
error ~data title message *)
|
|
||||||
|
|
||||||
let unsupported_deep_set_rm path =
|
let unsupported_deep_set_rm path =
|
||||||
let title () = "set removals" in
|
let title () = "set removals" in
|
||||||
let message () =
|
let message () =
|
||||||
@ -839,8 +827,28 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
|
|||||||
)
|
)
|
||||||
| MapPatch patch ->
|
| MapPatch patch ->
|
||||||
fail @@ unsupported_map_patches patch
|
fail @@ unsupported_map_patches patch
|
||||||
| SetPatch patch ->
|
| SetPatch patch -> (
|
||||||
fail @@ unsupported_set_patches patch
|
let setp = patch.value in
|
||||||
|
let (name , access_path) = simpl_path setp.path in
|
||||||
|
let%bind inj = bind_list
|
||||||
|
@@ List.map (fun (x:Raw.expr) ->
|
||||||
|
let%bind e = simpl_expression x
|
||||||
|
in ok e)
|
||||||
|
@@ pseq_to_list setp.set_inj.value.elements in
|
||||||
|
let%bind expr =
|
||||||
|
let aux = fun (v) ->
|
||||||
|
e_assign name access_path (e_constant "SET_ADD" [v ; e_variable name]) in
|
||||||
|
let assigns = List.map aux inj in
|
||||||
|
match assigns with
|
||||||
|
| [] -> fail @@ unsupported_empty_record_patch setp.set_inj
|
||||||
|
| hd :: tl -> (
|
||||||
|
let aux acc cur = e_sequence acc cur in
|
||||||
|
ok @@ List.fold_left aux hd tl
|
||||||
|
)
|
||||||
|
in
|
||||||
|
return_statement @@ expr
|
||||||
|
)
|
||||||
|
|
||||||
| 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
|
||||||
|
Loading…
Reference in New Issue
Block a user