Add rough draft of set patch functionality

This commit is contained in:
John David Pressman 2019-10-09 17:08:58 -07:00
parent 8dfb2a967f
commit 2f60c85aa8

View File

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