diff options
| -rw-r--r-- | rego-proofs/compiler-rewrite/bin/main.ml | 51 |
1 files changed, 38 insertions, 13 deletions
diff --git a/rego-proofs/compiler-rewrite/bin/main.ml b/rego-proofs/compiler-rewrite/bin/main.ml index ae65c61..14a1ff7 100644 --- a/rego-proofs/compiler-rewrite/bin/main.ml +++ b/rego-proofs/compiler-rewrite/bin/main.ml @@ -2,7 +2,7 @@ open Core open Yojson.Basic.Util type expr = Term of term - | Every of (string list) * term * query + | Every of (string option) * string * term * query [@@deriving show] and literal = expr * (with_modifier option) [@@deriving show] @@ -39,7 +39,7 @@ and object_key = Scalar of scalar | Ref of reference | Var of string [@@deriving show] -and with_modifier = (term * term) +and with_modifier = (term * term) list [@@deriving show] type assign_operator = Assign | Unify @@ -75,6 +75,10 @@ type package = } [@@deriving show] +let is_null : Yojson.Basic.t -> bool = function + | `Null -> true + | _ -> false + let to_bool_or_false : Yojson.Basic.t -> bool = function | `Bool b -> b | _ -> false @@ -113,32 +117,53 @@ let rec parse_term (tree : Yojson.Basic.t) : term = | "arraycomprehension" -> ArrayComprehension (tree |> member "value" |> member "term" |> parse_term, - tree |> member "value" |> member "body" |> to_list |> List.map ~f:(fun x -> (parse_expr x, None))) + tree |> member "value" |> member "body" |> to_list |> List.map ~f:parse_literal) | "setcomprehension" -> SetComprehension (tree |> member "value" |> member "term" |> parse_term, - tree |> member "value" |> member "body" |> to_list |> List.map ~f:(fun x -> (parse_expr x, None))) + tree |> member "value" |> member "body" |> to_list |> List.map ~f:parse_literal) | "objectcomprehension" -> ObjectComprehension ((tree |> member "value" |> member "key" |> parse_term |> object_key_of_term, tree |> member "value" |> member "value" |> parse_term), - tree |> member "value" |> member "body" |> to_list |> List.map ~f:(fun x -> (parse_expr x, None))) + tree |> member "value" |> member "body" |> to_list |> List.map ~f:parse_literal) | "call" -> (match tree |> member "value" |> to_list with | func :: args -> Call (func |> member "value" |> to_list |> parse_ref, List.map ~f:parse_term args) - | _ -> failwith "ill_formed call") + | _ -> failwith "ill-formed call") | _ -> failwith ("unsupported term type " ^ term_type) -and parse_expr tree : expr = - Printf.printf "%s: %s\n" "parse_expr" (Yojson.Basic.to_string tree); +and parse_literal tree : literal = + Printf.printf "%s: %s\n" "parse_literal" (Yojson.Basic.to_string tree); + let with_expr = tree |> member "with" in + let with_expr = match with_expr with + | `Null -> None + | `List xs -> + Some + (List.map xs ~f:(fun x -> (x |> member "target" |> parse_term, + x |> member "value" |> parse_term))) + | _ -> failwith ("ill-formed with expression " ^ (Yojson.Basic.to_string with_expr)) + in match tree |> member "terms" with | `List (func :: args) -> - Term (Call (func |> member "value" |> to_list |> parse_ref, - List.map ~f:parse_term args)) - | `List _ -> failwith "todo" - | x -> Term (parse_term x) + (Term (Call (func |> member "value" |> to_list |> parse_ref, + List.map ~f:parse_term args)), + with_expr) + | `List _ -> failwith "ill-formed call" + | x -> + if x |> member "domain" |> is_null then + (Term (parse_term x), with_expr) + else + (Every ((if x |> member "key" |> is_null then + None + else + Some (x |> member "key" |> member "value" |> to_string)), + x |> member "value" |> member "value" |> to_string, + x |> member "domain" |> parse_term, + (List.map ~f:parse_literal (x |> member "body" |> to_list))), + with_expr) and parse_ref_target tree : ref_target = Printf.printf "%s: %s\n" "parse_ref_target" (Yojson.Basic.to_string tree); @@ -176,7 +201,7 @@ let rec parse_rule tree = Printf.printf "%s: %s\n" "rec parse_rule tree" (Yojson.Basic.to_string tree); { default = tree |> member "default" |> to_bool_or_false; head = tree |> member "head" |> parse_head; - body = List.map ~f:(fun x -> ((parse_expr x, None) : literal)) (tree |> member "body" |> to_list_or_empty); + body = List.map ~f:parse_literal (tree |> member "body" |> to_list_or_empty); otherwise = match tree |> member "else" with | `Null -> None |