Permalink
Browse files

[feature] compiler, database: Added update options in the database as…

…t + mongo generator
  • Loading branch information...
1 parent 1e66170 commit 2dc656eb715ca8d599c342e9b2bf2483361ee3e1 @BourgerieQuentin BourgerieQuentin committed Apr 10, 2012
@@ -1772,7 +1772,7 @@ module CodeGenerator ( Arg : DbGenByPass.S ) = struct
make_simple_virtual_val_path val_path
| Db.Option | Db.Default ->
get_path_expr sch dbinfo gamma node path kind
- | Db.Update update ->
+ | Db.Update (update, _) -> (* TODO : options *)
make_update_path ~context gamma (make_ref_path sch dbinfo gamma node path) node update
@@ -1942,7 +1942,7 @@ module CodeGenerator ( Arg : DbGenByPass.S ) = struct
match kind with
| Db.Ref ->
make_ref_path db_def.Schema_private.schema dbinfo gamma node path
- | Db.Update update ->
+ | Db.Update (update, _) -> (* TODO : options *)
let rpath = make_ref_path db_def.Schema_private.schema dbinfo gamma node path in
make_update_path ~context gamma rpath node update
| _ ->
@@ -1159,7 +1159,7 @@ module Preprocess = struct
let kind ~context gamma kind ty virtual_ =
match kind with
| Db.Option | Db.Default | Db.Ref | Db.Valpath -> kind
- | Db.Update u ->
+ | Db.Update (u, o) ->
let ty =
match virtual_ with
| `realpath -> ty
@@ -1201,7 +1201,7 @@ module Preprocess = struct
| Db.UPop -> error "" "pop is not available on %a" QmlPrint.pp#ty ty
| Db.UShift -> error "" "shift is not available on %a" QmlPrint.pp#ty ty
| Db.UIncr _ -> error "" "incr is not available on %a (only on int)" QmlPrint.pp#ty ty
- in Db.Update (update ty u)
+ in Db.Update ((update ty u), o)
let select ~context gamma select ty virtual_ =
let (dataty, rebuildt) =
@@ -1284,7 +1284,7 @@ let preprocess_paths_expr ?(val_=(fun _ -> assert false)) t gamma e =
| Db.Default -> dataty
| Db.Valpath -> C.Db.val_path_ty dataty
| Db.Ref -> C.Db.ref_path_ty dataty
- | Db.Update _u -> H.tyunit
+ | Db.Update (_, _) -> H.tyunit
in
let e =
(* Bind type variable of virtual path handler with virtual
@@ -171,6 +171,10 @@ struct
| UPrependAll of 'expr
| UPop | UShift
+ type 'expr update_options = {
+ ifexists : bool;
+ }
+
(** The kind of a path, ie the type of access it is *)
type 'expr kind =
| Option
@@ -185,7 +189,7 @@ struct
| Ref
(** No operation is done, just build a pointer to the database. used for
operations on paths (like writes) *)
- | Update of 'expr update
+ | Update of 'expr update * 'expr update_options
(** The paths as specified in definitions (eg. with possible definition of keys) *)
type path_decl_key =
@@ -251,6 +255,10 @@ struct
| Db_Constraint of path_decl * 'expr db_constraint
| Db_Virtual of path_decl * 'expr
+ let default_update_options = { ifexists = false }
+
+ let default_query_options = { limit = None; skip = None; sort = None }
+
let pp = BaseFormat.fprintf
let rec pp_field fmt = function
@@ -274,6 +282,24 @@ struct
| UPop -> pp fmt "pop"
| UShift -> pp fmt "shift"
+ let pp_update_options _pp_expr fmt o =
+ if o.ifexists then pp fmt "; ifexists"
+
+ let pp_update_with_options pp_expr fmt (u, o) =
+ if o = default_update_options then pp_update pp_expr fmt u
+ else (
+ pp fmt "{";
+ (match u with
+ | UFlds fields ->
+ List.iter
+ (function (f, u) ->
+ pp fmt "%a : %a," pp_field f (pp_update pp_expr) u) fields;
+ | _ -> pp_update pp_expr fmt u
+ );
+ pp fmt "%a}" (pp_update_options pp_expr) o
+ )
+
+
let rec pp_query pp_expr fmt = function
| QEq expr -> pp fmt "== %a" pp_expr expr
| QGt expr -> pp fmt "> %a" pp_expr expr
@@ -328,7 +354,8 @@ struct
let pp_path pp_expr f (el, knd, select) =
let pp_el fmt () = pp_path_elts pp_expr fmt el in
match knd with
- | Update u -> pp f "%a.%a <- %a" pp_el () (pp_select pp_expr) select (pp_update pp_expr) u
+ | Update (u, o) ->
+ pp f "%a.%a <- %a" pp_el () (pp_select pp_expr) select (pp_update_with_options pp_expr) (u, o)
| _ ->
pp f "%s%a.%a" (
match knd with
@@ -425,6 +452,12 @@ struct
(fun fields -> UFlds fields)
(TU.sub_list (TU.sub_2 TU.sub_ignore (sub_db_update sub_e sub_ty)) fields)
+ let sub_db_update_options _sub_e _sub_ty opt =
+ TU.wrap
+ (fun (ifexists) -> {ifexists;})
+ ((TU.sub_ignore) (opt.ifexists))
+
+
let rec sub_db_select sub_e sub_ty = function
| (SStar | SNil) as e -> TU.sub_ignore e
| SSlice (e1, e2) -> TU.wrap (fun (e1, e2) -> SSlice (e1, e2)) (TU.sub_2 sub_e sub_e (e1, e2))
@@ -438,8 +471,11 @@ struct
| Option
| Valpath
| Ref as e -> TU.sub_ignore e
- | Update update ->
- TU.wrap (fun u -> Update u) (sub_db_update sub_e sub_ty update)
+ | Update (update, options) ->
+ TU.wrap (fun (u, o) -> Update (u,o))
+ (TU.sub_2 (sub_db_update sub_e sub_ty)
+ (sub_db_update_options sub_e sub_ty)
+ (update, options))
let rec sub_db_query sub_e sub_ty = function
| QMod _ as e -> TU.sub_ignore e
@@ -475,7 +511,7 @@ struct
(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 _
@@ -407,7 +407,7 @@ module Generator = struct
let dataty = node.DbSchema.ty in
let dbname = node.DbSchema.database.DbSchema.name in
match kind with
- | DbAst.Update u ->
+ | DbAst.Update (u, o) ->
begin match node.DbSchema.kind with
| DbSchema.Plain ->
let annotmap, path = expr_of_strpath gamma annotmap strpath in
@@ -453,7 +453,7 @@ module Generator = struct
| Some (annotmap, subu) ->
let annotmap, sube =
string_path ~context gamma annotmap schema
- (DbAst.Update subu, dbname::subpath)
+ (DbAst.Update (subu, o), dbname::subpath)
in (annotmap, Some (Ident.next "_", sube))
| None -> annotmap, None
) annotmap c
@@ -556,7 +556,7 @@ module Generator = struct
annotmap, skip, limit, query, opt.DbAst.sort, uniq
in
match query0, kind with
- | None, DbAst.Update DbAst.UExpr e ->
+ | None, DbAst.Update (DbAst.UExpr e, _options) (* TODO : options *) ->
(* Just reuse ref path on collections if 0 query *)
let annotmap, refpath =
dbset_path ~context gamma annotmap (DbAst.Ref, path) setkind node query0 embed select0 in
@@ -679,7 +679,7 @@ module Generator = struct
| _ -> assert false
end
- | DbAst.Update u ->
+ | DbAst.Update (u, o) ->
let (annotmap, query) = query_to_expr gamma annotmap query in
let (annotmap, update) =
let u =
@@ -690,10 +690,14 @@ module Generator = struct
in
update_to_expr gamma annotmap u
in
+ let annotmap, upsert =
+ if o.DbAst.ifexists then C._false (annotmap, gamma)
+ else C._true (annotmap, gamma)
+ in
let (annotmap, build) =
OpaMapToIdent.typed_val ~label Api.DbSet.update annotmap gamma
in
- (annotmap, build, query, [update])
+ (annotmap, build, query, [update; upsert])
in
(* database *)
let (annotmap, database) = node_to_dbexpr gamma annotmap node in
@@ -59,13 +59,15 @@ path_kind <- querytype:qt path:p select:s {{ p, qt, s }}
; /** database update path **/
path_update <-
- / '@'? slash_nosp path:pa select:s spacing (Opa_lexer.larrow update:u {{u}} / update_simple):u
+ / '@'? slash_nosp path:pa select:s spacing
+ (Opa_lexer.larrow update:u {{u}} / update_simple:u {{u, QmlAst.Db.default_update_options}}):u
{{
- DBPath (pa, QmlAst.Db.Update u, s)
+ let u, o = u in
+ DBPath (pa, QmlAst.Db.Update (u, o), s)
}}
/ '@'? slash_nosp path:pa select:s spacing (Opa_lexer.larrow / Opa_lexer.assign) Opa_parser.expr:e
{{
- DBPath (pa, QmlAst.Db.Update (QmlAst.Db.UExpr e), s)
+ DBPath (pa, QmlAst.Db.Update ((QmlAst.Db.UExpr e), QmlAst.Db.default_update_options), s)
}}
@@ -74,11 +76,25 @@ path_update <-
{7 Path updating }
*)
update <-
- / update_fields:u {{ u }}
+ / lbrace update_simple:u update_options:o rbrace {{ u, o }}
+ / tilda:tilda lbrace update_fields:u update_options:o rbrace {{ u tilda, o }}
+ / update_noopt:u {{ u, QmlAst.Db.default_update_options }}
+
+update_options <- Opa_parser.separator (=list0(update_options_ifexists, Opa_parser.separator)):l
+ {{
+ let options = QmlAst.Db.default_update_options in
+ List.fold_left (fun opt f -> f opt) options l
+ }}
+
+update_options_ifexists <- (=Opa_lexer.exact_keyword("ifexists"))
+ {{ fun _opt -> {QmlAst.Db.ifexists = true } }}
+
+update_noopt <-
+ / tilda:tilda lbrace update_fields:u rbrace {{ u tilda }}
/ Opa_parser.expr:e {{ QmlAst.Db.UExpr e }}
update_field <-
- / Opa_parser.record_long_ident:i (Opa_parser.record_fields_assign update:e {{e}} / update_simple):e
+ / Opa_parser.record_long_ident:i (Opa_parser.record_fields_assign update_noopt:e {{e}} / update_simple):e
{{ `binding (List.map undecorate i, e) }}
/ tilda:tilda Opa_parser.record_short_ident:i
{{
@@ -87,11 +103,9 @@ update_field <-
}}
update_fields <-
- tilda:tilda lbrace
(=list0(update_field, Opa_parser.record_fields_separator)):l Opa_parser.record_fields_separator?
- rbrace
{{
- QmlAst.Db.UFlds (default_value_in_expr_update tilda l)
+ function tilda -> QmlAst.Db.UFlds (default_value_in_expr_update tilda l)
}}
update_simple <- update_incr / update_list
@@ -123,12 +137,12 @@ update_list <-
{7 Path selection }
*)
;/** Path selection **/
-select <-
+select <-
/ "." (select_fields / select_list / select_star):s {{ s }}
/ select_nil
select_field <-
- / Opa_parser.record_long_ident:i select:e
+ / Opa_parser.record_long_ident:i select:e
{{ List.map undecorate i, e }}
select_fields <-
@@ -143,7 +157,7 @@ select_list <-
/ lbracket Opa_parser.expr:e rbracket {{ QmlAst.Db.SSlice (e, none (label e)) }}
/ lbracket Opa_parser.expr:e1 Opa_lexer.comma Opa_parser.expr:e2 rbracket {{ QmlAst.Db.SSlice (e1, e2) }}
-select_star <- "*" {{ QmlAst.Db.SStar }}
+select_star <- "*" {{ QmlAst.Db.SStar }}
select_nil <- _succeed {{ QmlAst.Db.SNil }}
@@ -234,15 +248,15 @@ query_options_order <-
query_options <-
(=list0((query_options_limit / query_options_skip / query_options_order), Opa_parser.separator)):l
{{
- let options = {QmlAst.Db.limit = None; skip = None; sort = None} in
+ let options = QmlAst.Db.default_query_options in
List.fold_left (fun opt f -> f opt) options l
}}
query_with_options <-
/ query:q (Opa_parser.separator query_options:o {{o}})?:o
{{
let options =
- Option.default {QmlAst.Db.limit = None; skip = None; sort = None} o
+ Option.default QmlAst.Db.default_query_options o
in
QmlAst.Db.Query (q, options)
}}
View
@@ -506,14 +506,22 @@ struct
aux original_expr
and kind k = match k with
- | QA.Db.Update update ->
+ | QA.Db.Update (update, options) ->
let rebuild, exprs =
QmlAst.Db.sub_db_update
Traverse.Utils.sub_current
Traverse.Utils.sub_ignore
update in
let exprs' = List.map expr exprs in
- QA.Db.Update (rebuild exprs')
+ let update = rebuild exprs' in
+ let rebuild, exprs =
+ QmlAst.Db.sub_db_update_options
+ Traverse.Utils.sub_current
+ Traverse.Utils.sub_ignore
+ options in
+ let exprs' = List.map expr exprs in
+ let options = rebuild exprs' in
+ QA.Db.Update (update, options)
| QA.Db.Default -> QA.Db.Default
| QA.Db.Option -> QA.Db.Option
| QA.Db.Valpath -> QA.Db.Valpath

0 comments on commit 2dc656e

Please sign in to comment.