Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

[enhance] compiler: added query ast + add node to update ast

  • Loading branch information...
commit 6ada700cd9cd3587a815c3385fd6c9919a6584d6 1 parent ccded04
@BourgerieQuentin BourgerieQuentin authored
View
1  libqmlcompil/dbGen/dbGen_private.ml
@@ -1819,6 +1819,7 @@ module CodeGenerator ( Arg : DbGenByPass.S ) = struct
let rpath = make_ref_path sch dbinfo gamma node path in
let dbwrite = Helpers_gen.expr_write node.C.ty in
H.apply_lambda' dbwrite [rpath; expr]
+ | _ -> assert false
(* | _ -> QmlError.error context "This update operation was not yet handled by db3 generator" *)
let get_expr ~context t dbinfo_map gamma path kind =
View
30 libqmlcompil/dbGen/schema_private.ml
@@ -976,7 +976,7 @@ let find_exprpath ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db.Option)
QmlPrint.pp#path_elts p
| _::_::_ -> assert false
-let preprocess_kind kind ty virtual_ =
+let preprocess_kind ~context kind ty virtual_ =
match kind with
| Db.Option | Db.Default | Db.Ref | Db.Valpath -> kind
| Db.Update u ->
@@ -987,9 +987,35 @@ let preprocess_kind kind ty virtual_ =
| _ -> assert false
in
let rec update ty u =
+ let error fmt0 fmt =
+ QmlError.error context ("Can't update "^^fmt0^^" because "^^fmt)
+ in
match u with
| Db.UExpr e ->
Db.UExpr (QmlAstCons.UntypedExpr.coerce e ty)
+ | Db.UFields fields ->
+ let rec dots field ty =
+ let rec aux field ty =
+ match field with
+ | [] -> ty
+ | f::t ->
+ match ty with
+ | Q.TypeRecord Q.TyRow (row, _var) ->
+ let ty =
+ try List.assoc f row with Not_found ->
+
+ error "todo" "%s is not found" f
+ in aux t ty
+ | _ -> error "tofo" "todo2"
+ in aux field ty
+ in
+ Db.UFields (List.map (function (field, u) -> (field, update (dots field ty) u)) fields)
+ | Db.UIncr _ when (
+ match ty with
+ | Q.TypeConst Q.TyInt -> true
+ | _ -> false
+ ) -> u
+ | Db.UIncr _ -> error "" "incr is not avialable only on %a" QmlPrint.pp#ty ty
in Db.Update (update ty u)
let preprocess_path ~context t prepath kind =
@@ -1000,7 +1026,7 @@ let preprocess_path ~context t prepath kind =
let n, virtual_ = find_exprpath ~context db_def.schema db_def.virtual_path ~node:root ~kind epath in
let label = Annot.nolabel "dbgen.preprocess_path" in
let ty = SchemaGraphLib.type_of_node n in
- let kind = preprocess_kind kind ty virtual_ in
+ let kind = preprocess_kind ~context kind ty virtual_ in
new_annots, Q.Path (label, List.map (fun f -> Db.FldKey f) prefix @ epath, kind), ty, virtual_
View
34 libqmlcompil/qmlAst.ml
@@ -128,8 +128,22 @@ end
module Db =
struct
+ type 'expr query =
+ | QGt of 'expr
+ | QLt of 'expr
+ | QGte of 'expr
+ | QLte of 'expr
+ | QNe of 'expr
+ | QMod of int
+ | QIn of 'expr
+ | QOr of 'expr
+ | QAnd of 'expr
+ | QNot of 'expr query
+
type 'expr update =
+ | UFields of (string list * 'expr update) list
| UExpr of 'expr
+ | UIncr of int
(** The kind of a path, ie the type of access it is *)
type 'expr kind =
@@ -164,6 +178,7 @@ struct
| FldKey of string
| ExprKey of 'expr
| NewKey
+ | Query of 'expr query
type 'expr path = 'expr path_elt list
@@ -213,9 +228,21 @@ struct
| Db_Constraint of path_decl * 'expr db_constraint
| Db_Virtual of path_decl * 'expr
+ let rec pp_field fmt = function
+ | t0::((_::_) as q) -> Format.fprintf fmt "%s.%a" t0 pp_field q
+ | t0::[] -> Format.fprintf fmt "%s" t0
+ | [] -> Format.fprintf fmt ""
+
+ let update_to_string = function
+ | UExpr _ -> "uexpr"
+ | UFields fields ->
+ Printf.sprintf "fields %s;"
+ (List.to_string (fun (f,_) -> List.to_string (fun x -> x) f) fields)
+ | UIncr i -> Printf.sprintf "+=%i" i
+
let path_kind_to_string = function
| Default -> "" | Option -> "?" | Valpath -> "!" | Ref -> "@"
- | Update _ -> "Update TODO"
+ | Update u -> Printf.sprintf "<- %s" (update_to_string u)
let engine_to_string opt =
match opt with
@@ -295,9 +322,12 @@ struct
| Db_Virtual (p,e) ->
TU.wrap (fun (p,e) -> Db_Virtual (p,e)) (TU.sub_2 TU.sub_ignore sub_e (p,e))
- let sub_db_update sub_e _sub_ty = function
+ let rec sub_db_update sub_e sub_ty = function
| UExpr expr ->
TU.wrap (fun e -> UExpr e) (sub_e expr)
+ | UIncr _ as e -> TU.sub_ignore e
+ | UFields fields ->
+ TU.wrap (fun fields -> UFields fields) (TU.sub_list (TU.sub_2 TU.sub_ignore (sub_db_update sub_e sub_ty)) fields)
let sub_db_kind sub_e sub_ty = function
| Default
View
19 libqmlcompil/qmlAstWalk.ml
@@ -621,8 +621,18 @@ struct
| QmlAst.Db.UExpr e ->
let acc, e' = tra acc e in
acc,
- if e == e' then u else
- QmlAst.Db.UExpr e'
+ if e == e' then u else QmlAst.Db.UExpr e'
+ | QmlAst.Db.UIncr _i -> acc, u
+ | QmlAst.Db.UFields fields ->
+ let acc, fields' =
+ List.fold_left_map_stable
+ (fun acc ((f,u) as bnd) ->
+ let acc, u' = update acc u in
+ acc,
+ if u == u' then bnd else (f, u')
+ ) acc fields in
+ acc,
+ if fields == fields' then u else QmlAst.Db.UFields fields'
in
let acc, u' = update acc u in
acc,
@@ -675,6 +685,11 @@ struct
let rec update acc u =
match u with
| QmlAst.Db.UExpr e -> tra acc e
+ | QmlAst.Db.UIncr _i -> acc
+ | QmlAst.Db.UFields fields ->
+ List.fold_left
+ (fun acc (_,u) -> update acc u)
+ acc fields
in update acc u
| _ -> acc
in acc
View
7 libqmlcompil/qmlDbGen.ml
@@ -229,11 +229,8 @@ module Schema = struct
let next = next declaration.Sch.schema node fragment in
match fragment with
| DbAst.ExprKey expr ->
- let kind =
- match kind with
- | Compose _ -> SetAccess (path, false, Expr expr)
- | _ -> assert false
- in (next, kind, path)
+ let kind = SetAccess (path, false, Expr expr) in
+ (next, kind, path)
| DbAst.FldKey key ->
let kind =
View
3  libqmlcompil/typer_w/w_Infer.ml
@@ -1033,6 +1033,9 @@ and infer_db_path ~bypass_typer typing_env ~surrounding_path_expr keys kind =
let (_e_ty, e_annotmap) =
infer_expr_type ~bypass_typer typing_env e in
QmlAnnotMap.merge annotmap_accu e_annotmap
+ | QmlAst.Db.UIncr _i -> annotmap_accu
+ | QmlAst.Db.UFields fields ->
+ List.fold_left (fun a (_,u) -> aux a u) annotmap_accu fields
in aux annotmap' u
in
perform_infer_expr_type_postlude surrounding_path_expr annotmap' ty
View
11 opalang/classic_syntax/opa_parser.trx
@@ -490,11 +490,8 @@ just_se_expr <-
let l = list_expr_of_expr_list [a] p in
dom_transform l
}}
- (* dbpath write *)
- / pos:p Parser_path.path_write:pa write_expr:e2
- {{
- DBPath (pa, QmlAst.Db.Update (QmlAst.Db.UExpr e2))
- }}
+ (* dbpath update *)
+ / Parser_path.path_update
/** top expr **/
just_top_expr <-
@@ -987,6 +984,10 @@ just_record <- tilda:tilda lbrace record_fields:f rbrace {{
;record_fields <- (=list0(record_element,separator)):l separator {{ l }}
;extend_record_fields <- (=list0(extend_record_element,separator)):l separator {{ l }}
+record_fields_separator <- separator
+
+record_fields_assign <- assign
+
extend_record_element <-
/ long_binding:b {{ `binding b }}
/ tilda:tilda (=deco(long_ident)):lp may_coerce:t not_assign
View
35 opalang/classic_syntax/parser_path.trx
@@ -55,9 +55,38 @@ pathdef_type <- spacing pathdef_type_nosp:v {{ v }}
;/** database query **/
query <- querytype:qt path:p {{ p, qt }}
-(* path for writing (no leading !,@ etc.) *)
-; /** database write path **/
-path_write <- slash_nosp path:p {{ p }}
+; /** database update path **/
+path_update <-
+ / slash_nosp path:pa Opa_lexer.larrow Opa_parser.expr:e
+ {{
+ DBPath (pa, QmlAst.Db.Update (QmlAst.Db.UExpr e))
+ }}
+ / slash_nosp path:pa Opa_lexer.larrow update_expr:u
+ {{
+ DBPath (pa, QmlAst.Db.Update u)
+ }}
+
+update_expr <-
+ / Opa_parser.expr:e {{ QmlAst.Db.UExpr e }}
+ / lbrace update_fields:u rbrace {{ u }}
+
+update_field <-
+ / Opa_parser.long_ident:i (Opa_parser.record_fields_assign update_expr:e {{e}} / update_incr):e
+ {{ (List.map undecorate i, e) }}
+
+update_fields <-
+ (=list0(update_field, Opa_parser.record_fields_separator)):l Opa_parser.record_fields_separator?
+ {{ QmlAst.Db.UFields l }}
+
+update_incr <-
+ / (=Opa_lexer.exact_symbol("++"))
+ {{ QmlAst.Db.UIncr 1 }}
+ / (=Opa_lexer.exact_symbol("+=")) Opa_lexer.spacing Opa_lexer.int:i
+ {{ QmlAst.Db.UIncr i }}
+ / (=Opa_lexer.exact_symbol("--"))
+ {{ QmlAst.Db.UIncr (-1) }}
+ / (=Opa_lexer.exact_symbol("-=")) Opa_lexer.spacing Opa_lexer.int:i
+ {{ QmlAst.Db.UIncr (-i) }}
;querytype <- [?] slash_nosp {{ QmlAst.Db.Option }}
/ [!] slash_nosp {{ QmlAst.Db.Valpath }}
View
6 opalang/js_syntax/opa_parser.trx
@@ -1027,8 +1027,10 @@ record_fields <- (=list0(record_element, record_fields_separator)):l record_fiel
record_fields_separator <- spacing comma
+record_fields_assign <- colon
+
record_element <-
- / (=type_maybe(field_identifier:i colon expr:e
+ / (=type_maybe(field_identifier:i record_fields_assign expr:e
{{ function t -> `binding (i,may_coerce_expr e t) }}
))
/ (binding_lambda / binding_module):b
@@ -1063,7 +1065,7 @@ record_with_element <-
record_long_ident_nosp <- deco_ml_identifier_nosp:i ('.' deco_field_identifier_nosp:i {{i}})*:l {{ i :: l }}
record_long_ident <- spacing record_long_ident_nosp:i {{i}}
record_long_binding <-
- / record_long_ident:i colon expr:e {{ (i, e) }}
+ / record_long_ident:i record_fields_assign expr:e {{ (i, e) }}
(* ******************************************************************)
View
5 opalang/opaToQml.ml
@@ -505,8 +505,11 @@ struct
and kind k = match k with
| QA.Db.Update update ->
- let aux_update = function
+ let rec aux_update = function
| QA.Db.UExpr sa -> QA.Db.UExpr (expr sa)
+ | QA.Db.UIncr _i as u -> u
+ | QA.Db.UFields fields ->
+ QA.Db.UFields (List.map (fun (f, u) -> (f, aux_update u)) fields)
in QA.Db.Update (aux_update update)
| QA.Db.Default -> QA.Db.Default
| QA.Db.Option -> QA.Db.Option
View
13 passes/surfaceAstRenaming.ml
@@ -1232,13 +1232,22 @@ and f_kind all_env hierar kind =
| QmlAst.Db.Valpath
| QmlAst.Db.Ref as e -> (all_env.f, e)
| QmlAst.Db.Update u ->
- let rec update all_env hierar u =
+ let rec update f_env hierar u =
match u with
| QmlAst.Db.UExpr e ->
let f_env, e = f_expr all_env hierar e in
f_env, QmlAst.Db.UExpr e
+ | QmlAst.Db.UIncr _i as u -> f_env, u
+ | QmlAst.Db.UFields fields ->
+ let f_env, fields =
+ List.fold_left_map
+ (fun f_env (f,u) ->
+ let f_env, u = update f_env hierar u in
+ f_env, (f, u))
+ f_env fields
+ in f_env, QmlAst.Db.UFields fields
in
- let f_env, u = update all_env hierar u in
+ let f_env, u = update all_env.f hierar u in
f_env, QmlAst.Db.Update u
View
1  protocols/gen_compare.ml
@@ -18,6 +18,7 @@
(* FIXME: remove open *)
module B = Base
let (<|) f a = f a
+
let (|>) a f = f a
let ( @* ) g f x = g(f(x))
module O = Ocaml
View
3  protocols/gen_printer.ml
@@ -17,6 +17,7 @@
*)
module B = Base
let (<|) f a = f a
+
let (|>) a f = f a
let ( @* ) g f x = g(f(x))
module O = Ocaml
@@ -67,7 +68,7 @@ and rewrite_pattern in_sub n = function
"int64" -> "Int64.to_string"
| _ -> Printf.sprintf "string_of_%s" t in
Printf.sprintf " ^ (%s __%s)%s" stroft
- (string_of_int n)
+ (string_of_int n)
<| rewrite_pattern in_sub (succ n) tail
| _ -> assert false
View
1  stdlib/apis/mongo/bson.opa
@@ -666,6 +666,7 @@ Bson = {{
[H.arr(key,doc)]
opa_to_document(key:string, v:'a, ty:OpaType.ty): Bson.document =
+ v = Magic.id(v)
match ty with
| {TyName_args=[]; TyName_ident="void"} -> [H.null(key)]
| {TyConst={TyInt={}}} -> [H.i64(key,(@unsafe_cast(v):int))]
Please sign in to comment.
Something went wrong with that request. Please try again.