Skip to content

Commit

Permalink
[enhance] compiler, database, mongo: Added exists + handle new fields
Browse files Browse the repository at this point in the history
  • Loading branch information
@BourgerieQuentin
BourgerieQuentin committed May 9, 2012
1 parent 08681a2 commit 0e94ee0
Showing 1 changed file with 35 additions and 40 deletions.
75 changes: 35 additions & 40 deletions opa/pass_MongoAccessGeneration.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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) ->
Expand All @@ -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

Expand All @@ -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"
Expand All @@ -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
Expand Down Expand Up @@ -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 ->
Expand Down Expand Up @@ -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 =
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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 (
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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,
Expand All @@ -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
Expand Down

0 comments on commit 0e94ee0

Please sign in to comment.