From 53b5fadebbf532011f264ddc01f5e482f0c93cd3 Mon Sep 17 00:00:00 2001 From: Bourgerie Quentin Date: Thu, 26 Jan 2012 12:38:03 +0100 Subject: [PATCH] [enhance] compiler, database: Added query options --- libqmlcompil/dbGen/schema_private.ml | 56 ++++++++++++++++++++++------ libqmlcompil/qmlAst.ml | 27 +++++++++++++- libqmlcompil/qmlDbGen.ml | 11 +++--- libqmlcompil/qmlDbGen.mli | 2 +- opa/pass_MongoAccessGeneration.ml | 4 +- 5 files changed, 79 insertions(+), 21 deletions(-) diff --git a/libqmlcompil/dbGen/schema_private.ml b/libqmlcompil/dbGen/schema_private.ml index 5f7ef18a..45dc3cb1 100644 --- a/libqmlcompil/dbGen/schema_private.ml +++ b/libqmlcompil/dbGen/schema_private.ml @@ -827,12 +827,45 @@ let rec dots gamma field ty = | Some msg -> Format.fprintf fmt "\n@{Hint@} : %s" msg) ()) ) -let coerce_query_element ~context gamma ty query = - let rec aux new_annots ty query = - let coerce wrap ty expr = - let e = QmlAstCons.UntypedExpr.coerce expr ty in - Q.QAnnot.expr e::new_annots, wrap e +let coerce_query_element ~context gamma ty (query, options) = + let coerce new_annots wrap ty expr = + let e = QmlAstCons.UntypedExpr.coerce expr ty in + Q.QAnnot.expr e::new_annots, wrap e + in + let a, options = + let a = [] in + let optmap f a o = match o with + | None -> a, None + | Some o -> let x, y = f a o in x, Some y in + let a, limit = + optmap + (fun a -> coerce a (fun x -> x) (Q.TypeConst Q.TyInt)) + a options.Db.limit + in let a, skip = + optmap + (fun a -> coerce a (fun x -> x) (Q.TypeConst Q.TyInt)) + a options.Db.skip + in let a, sort = + let ty = + Q.TypeRecord ( + let void = Q.TypeRecord (QmlAstCons.Type.Row.make []) in + QmlAstCons.Type.Row.make [ + ("up", void); + ("down", void); + ] + ) + in + optmap + (fun a fields -> + List.fold_left_map + (fun a (flds, e) -> coerce a (fun e -> (flds, e)) ty e) + a fields + ) a options.Db.sort in + (a, {Db.limit; skip; sort}) + in + let rec aux new_annots ty query = + let coerce = coerce new_annots in let aux2 wrap ty (q1, q2) = let new_annots, q1 = aux new_annots ty q1 in let new_annots, q2 = aux new_annots ty q2 in @@ -867,7 +900,8 @@ let coerce_query_element ~context gamma ty query = with Formatted p -> QmlError.error context "This querying is invalid because %a\n%!" p () - in aux [] ty query + in let a, query = aux a ty query in + a, (query, options) (** @return (new_annots_list, pppath) *) let rec convert_dbpath ~context t gamma node kind path0 path = @@ -952,16 +986,16 @@ let rec convert_dbpath ~context t gamma node kind path0 path = let new_annots, epath = convert_dbpath ~context t gamma (SchemaGraph.unique_next t node) kind path0 path in new_annots, Db.NewKey :: epath - | Db.Query query::[] -> - let new_annots, query = + | Db.Query (query, options)::[] -> + let new_annots, (query, options) = let ty = match SchemaGraphLib.type_of_node node with | Q.TypeName ([setparam], name) when Q.TypeIdent.to_string name = "dbset" -> setparam | _ -> SchemaGraphLib.type_of_key t node in - coerce_query_element ~context gamma ty query + coerce_query_element ~context gamma ty (query, options) in - new_annots, [Db.Query query] + new_annots, [Db.Query (query, options)] | Db.Query _::_path -> QmlError.error context "sub path after query is not handler yet" @@ -1018,7 +1052,7 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db QmlPrint.pp#path_elts epath0 in find_exprpath_aux ~context t ~node:next ~kind ~epath0 vpath epath - | (Db.Query _q)::epath, C.Multi -> + | (Db.Query (_, _))::epath, C.Multi -> let setty = node.C.ty in (match setty with | Q.TypeName ([setparam], name) diff --git a/libqmlcompil/qmlAst.ml b/libqmlcompil/qmlAst.ml index 54b69cb1..20962e4c 100755 --- a/libqmlcompil/qmlAst.ml +++ b/libqmlcompil/qmlAst.ml @@ -144,6 +144,12 @@ struct | QNot of 'expr query | QFlds of 'expr query fields + type 'expr query_options = { + limit : 'expr option; + skip : 'expr option; + sort : 'expr fields option; + } + type 'expr update = (* Record updating*) | UFlds of 'expr update fields @@ -192,7 +198,7 @@ struct | FldKey of string | ExprKey of 'expr | NewKey - | Query of 'expr query + | Query of 'expr query * 'expr query_options type 'expr path = 'expr path_elt list @@ -406,11 +412,28 @@ struct (fun fields -> QFlds fields) (TU.sub_list (TU.sub_2 TU.sub_ignore (sub_db_query sub_e sub_ty)) flds) + let sub_db_query_options sub_e _sub_ty opt = + let (sub_fields: ('a fields, _, _, 'b fields) TU.sub) = fun flds -> + TU.wrap + (fun fields -> fields) + (TU.sub_list (TU.sub_2 TU.sub_ignore sub_e) flds) + in + TU.wrap + (fun (limit, skip, sort) -> {limit; skip; sort}) + (TU.sub_3 (TU.sub_option sub_e) (TU.sub_option sub_e) (TU.sub_option sub_fields) + (opt.limit, opt.skip, (opt.sort : 'expr fields option)) + ) + let sub_path_elt sub_e sub_ty = function | FldKey _ | NewKey as v -> TU.sub_ignore v | ExprKey e -> TU.wrap (fun x -> ExprKey x) (sub_e e) - | Query query -> TU.wrap (fun q -> Query q) (sub_db_query sub_e sub_ty query) + | Query (q, o) -> + TU.wrap + (fun (q, o) -> Query (q, o)) + (TU.sub_2 (sub_db_query sub_e sub_ty) (sub_db_query_options sub_e sub_ty) + (q, o) + ) let foldmap_expr f acc dbdef = let cons, subs = sub_db_def TU.sub_current TU.sub_ignore dbdef in diff --git a/libqmlcompil/qmlDbGen.ml b/libqmlcompil/qmlDbGen.ml index 2d3c2718..d69de988 100644 --- a/libqmlcompil/qmlDbGen.ml +++ b/libqmlcompil/qmlDbGen.ml @@ -44,7 +44,7 @@ module Schema = struct package : ObjectFiles.package_name; } - type query = QmlAst.expr QmlAst.Db.query + type query = QmlAst.expr DbAst.query * QmlAst.expr DbAst.query_options type set_kind = | Map of QmlAst.ty * QmlAst.ty @@ -54,7 +54,7 @@ module Schema = struct | Compose of (string * string list) list | Plain | Partial of bool (* Inside sum*) * string list * string list - | SetAccess of set_kind * string list * (bool * query) option (*bool == unique*) + | SetAccess of set_kind * string list * (bool (*is_unique*) * query) option type node = { ty : QmlAst.ty; @@ -241,7 +241,8 @@ module Schema = struct match fragment with | DbAst.ExprKey expr -> let setkind = get_setkind llschema node in - let kind = SetAccess (setkind, path, Some (true, DbAst.QEq expr)) in + let options = {DbAst.limit = None; skip = None; sort = None} in + let kind = SetAccess (setkind, path, Some (true, (DbAst.QEq expr, options))) in (next, kind, path) | DbAst.FldKey key -> @@ -259,10 +260,10 @@ module Schema = struct | SetAccess _, _ -> raise (Base.NotImplemented "Selection inside a multi node") in let path = key::path in (next, kind, path) - | DbAst.Query query -> + | DbAst.Query (query, options) -> begin match kind with | SetAccess (_k, path, None) -> - let kind = SetAccess (get_setkind llschema node, path, Some (false, query)) in + let kind = SetAccess (get_setkind llschema node, path, Some (false, (query, options))) in (next, kind, path) | SetAccess (_, _path, Some _) -> raise (Base.NotImplemented "Selection inside a multi node") diff --git a/libqmlcompil/qmlDbGen.mli b/libqmlcompil/qmlDbGen.mli index 48fd23a0..b2f1fd8d 100644 --- a/libqmlcompil/qmlDbGen.mli +++ b/libqmlcompil/qmlDbGen.mli @@ -53,7 +53,7 @@ module Schema: sig package : ObjectFiles.package_name; } - type query = QmlAst.expr QmlAst.Db.query + type query = QmlAst.expr QmlAst.Db.query * QmlAst.expr QmlAst.Db.query_options type set_kind = | Map of QmlAst.ty * QmlAst.ty diff --git a/opa/pass_MongoAccessGeneration.ml b/opa/pass_MongoAccessGeneration.ml index 4f316c89..f625ec27 100644 --- a/opa/pass_MongoAccessGeneration.ml +++ b/opa/pass_MongoAccessGeneration.ml @@ -430,13 +430,13 @@ module Generator = struct let uniq, nb, query = match query0 with | None -> false, 0, None - | Some ((uniq, query) as x) -> + | Some ((uniq, (query, _opt)) as _x) -> uniq, (if uniq then 1 else 5000), Some ( match setkind with | DbSchema.Map _ -> uniq, DbAst.QFlds [(["_id"], query)] - | _ -> x) + | _ -> uniq, query) in (* DbSet.build *) let (annotmap, build, query, args) =