Permalink
Browse files

[enhance] compiler, database: Added query options

  • Loading branch information...
1 parent a689f5f commit 53b5fadebbf532011f264ddc01f5e482f0c93cd3 @BourgerieQuentin BourgerieQuentin committed Jan 26, 2012
@@ -827,12 +827,45 @@ let rec dots gamma field ty =
| Some msg -> Format.fprintf fmt "\n@{<bright>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)
@@ -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
@@ -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")
@@ -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
@@ -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) =

0 comments on commit 53b5fad

Please sign in to comment.