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

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 =

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_
 
 

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

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

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 =

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

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

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 }}

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) }}
 
 
 (* ******************************************************************)

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

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
 
 

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

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
 

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))]