Skip to content

Commit

Permalink
[enhance] compiler, dbgen, mongo: Handle query options on mongo acces…
Browse files Browse the repository at this point in the history 
…s generation
  • Loading branch information
@BourgerieQuentin
BourgerieQuentin committed Feb 1, 2012
1 parent 71e1ad4 commit e59cccd
Show file tree
Hide file tree
Showing 2 changed files with 75 additions and 36 deletions.
79 changes: 59 additions & 20 deletions opa/pass_MongoAccessGeneration.ml
View file
Expand Up @@ -121,10 +121,11 @@ module Generator = struct
| DbAst.QNot (DbAst.QAnd (q1, q2)) ->
DbAst.QOr (prepare_query (DbAst.QNot q1), prepare_query (DbAst.QNot q2))

let empty_query gamma annotmap = C.list (annotmap, gamma) []

let query_to_expr gamma annotmap query =
let empty_query annotmap = C.list (annotmap, gamma) [] in
match query with
| None -> empty_query annotmap
| None -> empty_query gamma annotmap
| Some (_todo, query) ->
let query = prepare_query query in
let rec aux annotmap query =
Expand All @@ -144,7 +145,7 @@ module Generator = struct
| DbAst.QIn _ -> "$in"
| _ -> assert false
in
let annotmap, query = empty_query annotmap in
let annotmap, query = empty_query gamma annotmap in
add_to_document gamma annotmap name e query
| DbAst.QFlds flds ->
List.fold_left
Expand All @@ -156,11 +157,11 @@ module Generator = struct
let annotmap, query = aux annotmap query in
add_to_document gamma annotmap name query acc
)
(empty_query annotmap)
(empty_query gamma annotmap)
flds
| DbAst.QNot query ->
let annotmap, query = aux annotmap query in
let annotmap, empty = empty_query annotmap in
let annotmap, empty = empty_query gamma annotmap in
add_to_document gamma annotmap "$not" query empty
| DbAst.QAnd (q1, q2)
| DbAst.QOr (q1, q2) ->
Expand All @@ -176,10 +177,35 @@ module Generator = struct
QmlAnnotMap.find_ty (Annot.annot (QmlAst.Label.expr q1)) annotmap
in
let annotmap, query = C.list ~ty (annotmap, gamma) [q1; q2] in
let annotmap, empty = empty_query annotmap in
let annotmap, empty = empty_query gamma annotmap in
add_to_document gamma annotmap name query empty
in aux annotmap query

let query_add_order gamma annotmap order query =
match order with
| None -> annotmap, query
| Some order ->
let annotmap, eorder =
List.fold_left
(fun (annotmap, acc) (fld, expr) ->
let name = BaseFormat.sprintf "%a" QmlAst.Db.pp_field fld in
let annotmap, expr =
let annotmap, up = C.int annotmap 1 in
let annotmap, pup =
let annotmap, any = QmlAstCons.TypedPat.any annotmap in
QmlAstCons.TypedPat.record annotmap ["up", any] in
let annotmap, down = C.int annotmap (-1) in
let annotmap, pdown =
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)
(empty_query gamma annotmap) order
in
let annotmap, metaquery = empty_query gamma annotmap in
let annotmap, metaquery = add_to_document gamma annotmap "$query" query metaquery in
add_to_document gamma annotmap "$orderby" eorder metaquery

let update_to_expr ?(set=true) gamma annotmap = function
| DbAst.UExpr e ->
let annotmap, uexpr = opa2doc gamma annotmap e () in
Expand Down Expand Up @@ -427,16 +453,28 @@ module Generator = struct
| _ -> ()
in
let ty = node.DbSchema.ty in
let uniq, nb, query =
let annotmap, skip, limit, query, order, uniq =
match query0 with
| None -> false, 0, None
| Some ((uniq, (query, _opt)) as _x) ->
uniq,
(if uniq then 1 else 5000),
Some (
| None ->
let annotmap, limit = C.int annotmap 1 in
let annotmap, skip = C.int annotmap 0 in
annotmap, skip, limit, None, None, false
| Some ((uniq, (query, opt)) as _x) ->
let annotmap, limit =
match opt.DbAst.limit with
| None -> C.int annotmap 0
| Some i -> annotmap, i
in let annotmap, skip =
match opt.DbAst.skip with
| None -> C.int annotmap 0
| Some i -> annotmap, i
in let query = Some (
match setkind with
| DbSchema.Map _ -> uniq, DbAst.QFlds [(["_id"], query)]
| _ -> uniq, query)
| _ -> uniq, query
)
in
annotmap, skip, limit, query, opt.DbAst.sort, uniq
in
(* DbSet.build *)
let (annotmap, build, query, args) =
Expand All @@ -448,23 +486,24 @@ module Generator = struct
let dataty =
match setkind with
| DbSchema.DbSet ty -> ty
| DbSchema.Map _ -> QmlAstCons.Type.next_var () (* Dummy type variable, should never use*)
| DbSchema.Map _ -> QmlAstCons.Type.next_var ()
(* Dummy type variable, should never use*)
in
(* query *)
let (annotmap, query) = query_to_expr gamma annotmap query in
let (annotmap, nb) = C.int annotmap nb in
let (annotmap, default) = node.DbSchema.default annotmap in
let annotmap, query = query_to_expr gamma annotmap query in
let annotmap, query = query_add_order gamma annotmap order query in
let annotmap, default = node.DbSchema.default annotmap in
begin match kind with
| DbAst.Default | DbAst.Option ->
let annotmap, build =
OpaMapToIdent.typed_val ~label ~ty:[dataty] Api.DbSet.build annotmap gamma in
(annotmap, build, query, [default; nb])
(annotmap, build, query, [default; skip; limit])
| DbAst.Valpath ->
let annotmap, build =
OpaMapToIdent.typed_val ~label ~ty:[dataty; dataty] Api.DbSet.build_vpath annotmap gamma
in
let annotmap, read_map = get_read_map setkind uniq annotmap gamma in
(annotmap, build, query, [default; nb; read_map])
(annotmap, build, query, [default; skip; limit; read_map])
| DbAst.Ref ->
let annotmap, read_map = get_read_map setkind uniq annotmap gamma in
let wty, (annotmap, write_map) =
Expand All @@ -487,7 +526,7 @@ module Generator = struct
let annotmap, build =
OpaMapToIdent.typed_val ~label ~ty:[wty; dataty] Api.DbSet.build_rpath annotmap gamma
in
(annotmap, build, query, [default; nb; read_map; write_map])
(annotmap, build, query, [default; skip; limit; read_map; write_map])
| _ -> assert false
end

Expand Down
32 changes: 16 additions & 16 deletions stdlib/database/mongo/db.opa
View file
Expand Up @@ -415,9 +415,9 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
* {1 Interface}
*/
@package DbSet = {{
DbSet = {{
index(db:DbMongo.t, path:list(string), idx) =
@package index(db:DbMongo.t, path:list(string), idx) =
id = List.to_string_using("", "", ".", path)
key = List.map((name -> ~{name value={Int32=1}}), idx)
opt = 0
Expand All @@ -430,22 +430,22 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
do Log.error("DbGen/Mongo", "(failure) Error when creating index {idx} at {path}")
error("Error when creating index")
indexes(db:DbMongo.t, path:list(string), idxs) =
@package indexes(db:DbMongo.t, path:list(string), idxs) =
List.iter(index(db, path, _), idxs)
build(db:DbMongo.t, path:list(string), selector, default:'a, nb):dbset('a) =
@package build(db:DbMongo.t, path:list(string), selector, default:'a, skip, limit):dbset('a) =
#<Ifstatic:DBGEN_DEBUG>
do Log.notice("DbGen/Mongo", "DbSet.build : Selector {selector}")
#<End>
id = List.to_string_using("", "", ".", path)
reply=MongoDriver.query(db.db, 0, "{db.name}.{id}", 0, nb, selector, none)
reply=MongoDriver.query(db.db, 0, "{db.name}.{id}", skip, limit, selector, none)
match reply with
| {none} ->
do Log.error("DbGen/Query", "(failure) Read tn {id} set doesn't returns anything")
error("DbSet build error")
| {some=reply} -> ~{reply default}
update(db:DbMongo.t, path:list(string), selector, update) =
@package update(db:DbMongo.t, path:list(string), selector, update) =
id = List.to_string_using("", "", ".", path)
tag = Bitwise.lor(0, MongoCommon.UpsertBit)
tag = Bitwise.lor(tag, MongoCommon.MultiUpdateBit)
Expand Down Expand Up @@ -501,7 +501,7 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
to_list(dbset:dbset('a)) = fold([], dbset)(acc, a -> a +> acc)
to_map(dbset:dbset('a)):map('key, 'value) =
@package to_map(dbset:dbset('a)):map('key, 'value) =
fold_doc(Map.empty, dbset, (map:map('key, 'value), doc:Bson.document ->
match List.extract_p(x -> x.name == "_id", doc) with
| ({some=kdoc}, vdoc) ->
Expand Down Expand Up @@ -529,7 +529,7 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
)
)
map_to_uniq(dbset:dbset('a)):option('value) =
@package map_to_uniq(dbset:dbset('a)):option('value) =
fold_doc(none, dbset, (opt, doc ->
do @assert(Option.is_none(opt))
match List.extract_p(x -> x.name == "_id", doc) with
Expand All @@ -544,37 +544,37 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
)
)
map_to_uniq_def(dbset:dbset('a)):'value =
@package map_to_uniq_def(dbset:dbset('a)):'value =
match map_to_uniq(dbset) with
| {some=v:'value} -> v
| {none} -> @unsafe_cast(dbset.default)
set_to_uniq(dbset:dbset('a)):option('a) =
@package set_to_uniq(dbset:dbset('a)):option('a) =
match to_list(dbset) with
| [] -> none
| [uniq] -> some(uniq)
| _ -> do @assert(false) error("___")
set_to_uniq_def(dbset:dbset('a)):'a =
@package set_to_uniq_def(dbset:dbset('a)):'a =
match set_to_uniq(dbset) with
| {none} -> dbset.default
| {some = uniq} -> uniq
add_to_document(doc, name, value, ty):Bson.document =
@package add_to_document(doc, name, value, ty):Bson.document =
List.append(doc, Bson.opa_to_document(name, value, ty))
build_vpath(db:DbMongo.t, path:list(string), selector, default:'b, nb,
@package build_vpath(db:DbMongo.t, path:list(string), selector, default:'b, skip, limit,
read_map:dbset('a) -> option('b)):DbMongo.private.val_path('b) =
{
id = DbMongo.path_to_id(path)
read() = read_map(build(db, path, selector, @unsafe_cast(default), nb)):option('b)
read() = read_map(build(db, path, selector, @unsafe_cast(default), skip, limit)):option('b)
default = default
more = void
}
// [selector |
build_rpath(db:DbMongo.t, path:list(string), selector, default:'b, nb,
@package build_rpath(db:DbMongo.t, path:list(string), selector, default:'b, skip, limit,
read_map:dbset('a) -> option('b), write_map:'b -> Bson.document):DbMongo.private.ref_path('b) =
vpath = build_vpath(db, path, selector, default, nb, read_map)
vpath = build_vpath(db, path, selector, default, skip, limit, read_map)
write(data) =
do update(db, path, selector,
[{name="$set"; value={Document = write_map(data)}}]
Expand Down

0 comments on commit e59cccd

Please sign in to comment.