Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

[enhance] compiler, database, mongo: Added exists + handle new fields

  • Loading branch information...
commit 0e94ee0fc29fe7ce1c434a6ba6675806c8e69153 1 parent 08681a2
Quentin Bourgerie BourgerieQuentin authored
Showing with 35 additions and 40 deletions.
  1. +35 −40 opa/pass_MongoAccessGeneration.ml
75 opa/pass_MongoAccessGeneration.ml
View
@@ -126,11 +126,13 @@ module Generator = struct
in
C.rev_list (annotmap, gamma) path
- (** Path must be reverted *)
- let expr_of_strexprpath gamma annotmap path =
+ let strlst_to_field fld =
+ BaseFormat.sprintf "%a" (BaseFormat.pp_list "." Format.pp_print_string) fld
+
+ let expr_of_strexprpath_rev gamma annotmap path =
let path = match path with [] -> [`string "value"] | _ -> path in
let fld_to_string annotmap fld =
- C.string annotmap (BaseFormat.sprintf "%a" QmlAst.Db.pp_field fld)
+ C.string annotmap (strlst_to_field fld)
in
let rec aux annotmap prev_str prev_expr = function
| (`string s)::q -> aux annotmap (s::prev_str) prev_expr q
@@ -174,6 +176,9 @@ module Generator = struct
OpaMapToIdent.typed_val ~label Opacapi.String.flatten annotmap gamma
in C.apply gamma annotmap flatten [lst]
+ let expr_of_strexprpath gamma annotmap path =
+ expr_of_strexprpath_rev gamma annotmap (List.rev path)
+
let empty_query gamma annotmap = C.list (annotmap, gamma) []
let convert_embeded_path fragconv embed =
@@ -206,7 +211,7 @@ module Generator = struct
| DbAst.QNot DbAst.QGte e -> DbAst.QLt e
| DbAst.QNot DbAst.QLte e -> DbAst.QGt e
| DbAst.QNot DbAst.QNe e -> DbAst.QEq e
- | DbAst.QNot DbAst.QExists (p, b) -> DbAst.QExists (p, not b)
+ | DbAst.QNot DbAst.QExists b -> DbAst.QExists (not b)
| DbAst.QNot (DbAst.QIn _ | DbAst.QMod _) -> query
| DbAst.QNot (DbAst.QNot query) -> query
| DbAst.QNot (DbAst.QFlds flds) ->
@@ -221,7 +226,7 @@ module Generator = struct
| [] -> query
| _ ->
let acc = convert_embeded_path (fun x -> x) embed in
- DbAst.QAnd (DbAst.QExists (acc, true), query)
+ DbAst.QAnd (DbAst.QFlds [(acc, (DbAst.QExists true))], query)
in
prepare_query query
@@ -238,14 +243,11 @@ module Generator = struct
let (annotmap, e) = C.shallow_copy annotmap e in
opa2doc gamma annotmap e ()
| DbAst.QMod _ -> assert false
- | DbAst.QExists (p, b) ->
- let annotmap, name = expr_of_strexprpath gamma annotmap (List.rev p) in
+ | DbAst.QExists b ->
let annotmap, b = C.bool (annotmap, gamma) b in
let annotmap, query = empty_query gamma annotmap in
- let annotmap, exists = add_to_document gamma annotmap "$exists" b query in
- let annotmap, query = empty_query gamma annotmap in
- add_to_document0 gamma annotmap name exists query
- | DbAst.QGt e | DbAst.QLt e | DbAst.QGte e | DbAst.QLte e | DbAst.QNe e | DbAst.QIn e ->
+ add_to_document gamma annotmap "$exists" b query
+ | DbAst.QGt e | DbAst.QLt e | DbAst.QGte e | DbAst.QLte e | DbAst.QNe e | DbAst.QIn e->
let name =
match query with
| DbAst.QGt _ -> "$gt"
@@ -261,12 +263,12 @@ module Generator = struct
| DbAst.QFlds flds ->
List.fold_left
(fun (annotmap, acc) (fld, query) ->
- let name = BaseFormat.sprintf "%a" QmlAst.Db.pp_field fld in
+ let annotmap, name = expr_of_strexprpath gamma annotmap fld in
match query with
- | DbAst.QEq e -> add_to_document gamma annotmap name e acc
+ | DbAst.QEq e -> add_to_document0 gamma annotmap name e acc
| _ ->
let annotmap, query = aux annotmap query in
- add_to_document gamma annotmap name query acc
+ add_to_document0 gamma annotmap name query acc
)
(empty_query gamma annotmap)
flds
@@ -294,12 +296,12 @@ module Generator = struct
let select_to_expr gamma annotmap select =
let rec aux prev_fld ((annotmap, acc) as aacc) select =
- let get_name annotmap = expr_of_strexprpath gamma annotmap prev_fld in
+ let get_name annotmap = expr_of_strexprpath_rev gamma annotmap prev_fld in
match select with
| DbAst.SFlds flds ->
List.fold_left
(fun aacc (fld, select) ->
- aux (List.rev_map_append (fun s -> `string s) fld prev_fld) aacc select)
+ aux (List.rev_append fld prev_fld) aacc select)
aacc flds
| DbAst.SId (id, s) -> aux ((`expr id)::prev_fld) aacc s
| DbAst.SNil | DbAst.SStar ->
@@ -335,7 +337,7 @@ module Generator = struct
let annotmap, eorder =
List.fold_left
(fun (annotmap, acc) (fld, expr) ->
- let name = BaseFormat.sprintf "%a" QmlAst.Db.pp_field fld in
+ let annotmap, name = expr_of_strexprpath gamma annotmap fld in
let annotmap, expr =
let annotmap, up = C.int annotmap 1 in
let annotmap, pup =
@@ -346,7 +348,7 @@ module Generator = struct
let annotmap, any = QmlAstCons.TypedPat.any annotmap in
QmlAstCons.TypedPat.record annotmap ["down", any] in
C.match_ annotmap expr [(pup, up); (pdown, down)]
- in add_to_document gamma annotmap name expr acc)
+ in add_to_document0 gamma annotmap name expr acc)
(empty_query gamma annotmap) order
in
let annotmap, metaquery = empty_query gamma annotmap in
@@ -368,7 +370,7 @@ module Generator = struct
| DbAst.UFlds fields ->
List.fold_left
(fun (inc, set, other, annotmap) (f, u) ->
- let fld = List.rev_map_append (fun s -> `string s) f rfld in
+ let fld = List.rev_append f rfld in
collect fld (inc, set, other, annotmap) u)
(inc, set, other, annotmap) fields
| DbAst.UExpr e -> (inc, (rfld, e)::set, other, annotmap)
@@ -395,7 +397,7 @@ module Generator = struct
| [] -> acc
| (field, value)::q ->
let annotmap, value = C.int annotmap value in
- let annotmap, field = expr_of_strexprpath gamma annotmap field in
+ let annotmap, field = expr_of_strexprpath_rev gamma annotmap field in
aux (add_to_document0 gamma annotmap field value ~ty doc) q
in
let annotmap, iexpr = aux (C.list (annotmap, gamma) []) inc in
@@ -414,7 +416,7 @@ module Generator = struct
match field with
| [`string "_id"] -> aux acc q
| _ ->
- let annotmap, field = expr_of_strexprpath gamma annotmap field in
+ let annotmap, field = expr_of_strexprpath_rev gamma annotmap field in
aux (add_to_document0 gamma annotmap field value doc) q
in
if addset then (
@@ -428,7 +430,7 @@ module Generator = struct
List.fold_left
(fun (annotmap, uexpr) (fld, name, request) ->
let annotmap, empty = C.list (annotmap, gamma) [] in
- let annotmap, fld = expr_of_strexprpath gamma annotmap fld in
+ let annotmap, fld = expr_of_strexprpath_rev gamma annotmap fld in
let annotmap, request = add_to_document0 gamma annotmap fld request empty in
add_to_document gamma annotmap name request uexpr
) (annotmap, uexpr) other
@@ -442,7 +444,7 @@ module Generator = struct
| DbAst.UFlds fields ->
List.find_map
(fun (fields, u) -> match fields with
- | t::q when t = field -> Some (annotmap, DbAst.UFlds [q, u])
+ | `string t::q when t = field -> Some (annotmap, DbAst.UFlds [q, u])
| _ -> None)
fields
| _ -> None
@@ -452,7 +454,7 @@ module Generator = struct
| DbAst.SFlds fields ->
List.find_map
(fun (fields, u) -> match fields with
- | [t] when t = field ->
+ | [`string t] when t = field ->
Some (if u = DbAst.SNil then DbAst.SStar else u)
| [_t] -> None
| _t::_q -> assert false
@@ -612,6 +614,7 @@ module Generator = struct
| DbSchema.Partial (sum, rpath, partial) ->
if sum then QmlError.serror context "Update inside a sum path is forbidden";
let annotmap, path = expr_of_strpath gamma annotmap (dbname::rpath) in
+ let partial = List.map (fun s -> `string s) partial in
let annotmap, uexpr = update_to_expr gamma annotmap (DbAst.UFlds [partial, u]) in
let annotmap, database = node_to_dbexpr gamma annotmap node in
let annotmap, update =
@@ -722,8 +725,8 @@ module Generator = struct
| DbAst.QLte _
| DbAst.QNe _
| DbAst.QMod _
- | DbAst.QIn _ -> DbAst.QFlds [(["_id"], query)]
- | DbAst.QFlds flds -> DbAst.QFlds (List.map (fun (flds, q) -> ("_id"::flds, q)) flds)
+ | DbAst.QIn _ -> DbAst.QFlds [([`string "_id"], query)]
+ | DbAst.QFlds flds -> DbAst.QFlds (List.map (fun (flds, q) -> (`string "_id"::flds, q)) flds)
| DbAst.QNot q -> DbAst.QNot (insert_id q)
| DbAst.QAnd (q1, q2) -> DbAst.QAnd (insert_id q1, insert_id q2)
| DbAst.QOr (q1, q2) -> DbAst.QOr (insert_id q1, insert_id q2)
@@ -769,7 +772,7 @@ module Generator = struct
(fun fragment (select, post) ->
match fragment with
| DbAst.FldKey str ->
- DbAst.SFlds [[str], select],
+ DbAst.SFlds [[`string str], select],
(fun ((annotmap, expr), ty) ->
let ty = dot str ty in
let ae = C.dot gamma annotmap expr str in
@@ -865,8 +868,7 @@ module Generator = struct
| None -> C.none annotmap gamma
| Some embed ->
let strexprpath = convert_embeded_path (fun x -> x) embed in
- let annotmap, embed = expr_of_strexprpath gamma annotmap
- (List.rev strexprpath) in
+ let annotmap, embed = expr_of_strexprpath gamma annotmap strexprpath in
C.some annotmap gamma embed
in
(annotmap, build, query,
@@ -876,23 +878,16 @@ module Generator = struct
| DbAst.Update (u, o) ->
let (annotmap, query) = query_to_expr gamma annotmap query [] in
+ Format.eprintf "EMBED : %a\n%!" (QmlAst.Db.pp_path_elts QmlPrint.pp#expr) (Option.default [] embed);
let (annotmap, update) =
let u = Option.default_map u
- (function embed ->
- List.fold_right
- (fun fragment update -> match fragment with
- | DbAst.FldKey str -> DbAst.UFlds [[str], update]
- | DbAst.Query ((DbAst.QEq uexpr), _)
- | DbAst.ExprKey uexpr -> DbAst.UId (uexpr, update)
- | _ -> QmlError.error context
- "This kind of update access is not supported by mongo dbgen driver"
- ) embed u
- ) embed
+ (function embed -> DbAst.UFlds [convert_embeded_path (fun x -> x) embed, u])
+ embed
in
let u =
(* Hack : When map value is simple, adding the "value" field *)
match setkind with
- | DbSchema.Map (_, tyval) when ty_is_const gamma tyval -> DbAst.UFlds [["value"], u]
+ | DbSchema.Map (_, tyval) when ty_is_const gamma tyval -> DbAst.UFlds [[`string "value"], u]
| _ -> u
in
update_to_expr gamma annotmap u
Please sign in to comment.
Something went wrong with that request. Please try again.