[feature] compiler, database: Just naive update of libqmlcompil (for …

…path selection)

libqmlcompil/qmlAlphaConv.ml

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of OPA.
 
@@ -277,7 +277,12 @@ let rec expr t e =
     | Q.ExtendRecord (label, f, e, n) -> Q.ExtendRecord (label, f, expr t e, expr t n)
     | (Q.Bypass _) as by -> by
     | Q.Coerce (label, e, ty) -> Q.Coerce (label, expr t e, ty)
-    | Q.Path (label, p,h) -> Q.Path (label, List.map (function Q.Db.ExprKey e -> Q.Db.ExprKey (expr t e) | k -> k) p, h)
+    | Q.Path (_label, _p, _h, _s) as path ->
+        QmlAstWalk.Expr.traverse_map
+          (fun tra -> function
+           | Q.Path (_, _, _, _) as e -> tra e
+           | e -> expr t e)
+          path
 
     | Q.Directive (_, `backend_ident _,_,_) as e ->
         (* not going inside `backend_ident, because it does contain

libqmlcompil/qmlDbGen.ml

@@ -69,7 +69,13 @@ module Schema = struct
     default : QmlAst.annotmap -> (QmlAst.annotmap * QmlAst.expr);
   }
 
-  let pp_query fmt _e = Format.fprintf fmt "todo query"
+  let pp_query fmt = function
+    | None -> ()
+    | Some (u, (q, o)) ->
+        Format.fprintf fmt "[%a%a]/* uniq : %b */"
+          (QmlAst.Db.pp_query QmlPrint.pp#expr) q
+          (QmlAst.Db.pp_options QmlPrint.pp#expr) o
+          u
 
   let pp_set_kind fmt = function
     | DbSet ty -> Format.fprintf fmt "dbset(%a)" QmlPrint.pp#ty ty
@@ -90,7 +96,7 @@ module Schema = struct
         Format.fprintf fmt "@[<hov>access to %a : %a with %a@]"
           pp_path path
           pp_set_kind sk
-          (Option.pp_none pp_query) query
+          pp_query query
 
   let pp_node fmt node =
     Format.fprintf fmt "{@[<hov>type : %a; kind : %a; ...@]}"

libqmlcompil/qmlDependencies.ml

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of OPA.
 
@@ -257,7 +257,7 @@ let get_expr_dep_context ?filter e =
              (*{ acc with  fields_groups = List.fold (fun groups (p,_)-> add_group (get_fields_pat p) groups) acc.fields_groups _pel }*)
              (*let _p = List.map pel in*)
              (* FIXME: ??? don't know what to do *)
-         | Q.Path (_, dbelt, _)-> (
+         | Q.Path (_, dbelt, _, _)-> (
              let acc = Option.if_none filter (add_database acc) acc in
              (* taking the first elt of the path *)
              match List.hd dbelt with

libqmlcompil/qmlEffects.ml

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of OPA.
 
@@ -356,7 +356,7 @@ struct
         rewrite_arrow level its_effect qty
     | Q.Coerce (_, e, _) ->
         infer bp env effect (level+1) e
-    | Q.Path (_, el, _) ->
+    | Q.Path (_, el, _, _) ->
         List.iter (function
                      | Q.Db.ExprKey e -> ignore (infer bp env effect (level+1) e)
                      | _ -> ()) el;

libqmlcompil/qmlPrint.ml

@@ -324,17 +324,7 @@ object (self)
   | Q.String s -> Format.fprintf f "\"%s\"" (escaped_string s)
   | c -> Format.pp_print_string f (Q.Const.string_of_expr c)
 
-  method path f (el, knd) =
-    let pp_el fmt () = Format.fprintf fmt "%a" (pp_list "" self#path_elt) el in
-    match knd with
-    | Q.Db.Update u -> pp f "%a <- %a" pp_el () (QmlAst.Db.pp_update self#expr) u
-    | _ ->
-        pp f "%s%a" (
-          match knd with
-          | Q.Db.Default -> "" | Q.Db.Option -> "?"
-          | Q.Db.Valpath -> "!" | Q.Db.Ref -> "@"
-          | Q.Db.Update _ -> assert false
-        ) pp_el ()
+  method path f (el, knd, select) = QmlAst.Db.pp_path self#expr f (el, knd, select)
 
   method path_elts f el =
     pp f "%a" (pp_list "" self#path_elt) el
@@ -369,7 +359,7 @@ object (self)
         pp f "@[<2>{%s = %a} ::@ %a@]" s self#expr e1 self#expr e2
     | Q.Bypass (_, s) -> Format.pp_print_string f ("%%" ^ (BslKey.to_string s) ^ "%%")
     | Q.Coerce (_, e,ty) -> pp f "%a : %a" self#under_coerce#expr e self#ty ty
-    | Q.Path (_, el, knd) -> self#path f (el, knd)
+    | Q.Path (_, el, knd, select) -> self#path f (el, knd, select)
     | Q.Directive (_, `module_, [e], _) -> pp f "{%a}" self#reset#expr e
     | Q.Directive (_, dir, exprs, tys) -> self#directive f dir exprs tys
   method bind_field fmt (f, d) = pp fmt "%s = %a" f self#under_record#expr d

opa/pass_MongoAccessGeneration.ml

@@ -1,3 +1,21 @@
+(*
+    Copyright © 2011, 2012 MLstate
+
+    This file is part of OPA.
+
+    OPA is free software: you can redistribute it and/or modify it under the
+    terms of the GNU Affero General Public License, version 3, as published by
+    the Free Software Foundation.
+
+    OPA is distributed in the hope that it will be useful, but WITHOUT ANY
+    WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+    FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+    more details.
+
+    You should have received a copy of the GNU Affero General Public License
+    along with OPA. If not, see <http://www.gnu.org/licenses/>.
+*)
+
 (* shorthands *)
 module Q = QmlAst
 module C = QmlAstCons.TypedExpr
@@ -672,7 +690,7 @@ module Generator = struct
     (annotmap, set)
 
 
-  let path ~context gamma annotmap schema (label, dbpath, kind) =
+  let path ~context gamma annotmap schema (label, dbpath, kind, select) =
     let node = get_node ~context schema dbpath in
     match node.DbSchema.database.DbSchema.options.DbAst.backend with
     | `mongo -> (
@@ -697,7 +715,7 @@ module Generator = struct
             C.apply gamma annotmap p2p [mongopath]
         | _ -> annotmap, mongopath
       )
-    | `db3 -> annotmap, Q.Path (label, dbpath, kind)
+    | `db3 -> annotmap, Q.Path (label, dbpath, kind, select)
 
   let indexes gamma annotmap _schema node rpath lidx =
     let (annotmap, database) =
@@ -770,10 +788,10 @@ let clean_code gamma annotmap schema code =
 
 let process_path gamma annotmap schema code =
   let fmap tra annotmap = function
-    | Q.Path (label, path, kind) as expr ->
+    | Q.Path (label, path, kind, select) as expr ->
         let context = QmlError.Context.annoted_expr annotmap expr in
         let annotmap, result =
-          Generator.path ~context gamma annotmap schema (label, path, kind) in
+          Generator.path ~context gamma annotmap schema (label, path, kind, select) in
         tra annotmap result
     | e -> tra annotmap e
   in

qmlcps/qmlCpsRewriter.ml

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of OPA.
 
@@ -885,7 +885,7 @@ let il_of_qml ?(can_skip_toplvl=false) (env:env) (private_env:private_env) (expr
 
     | Q.Coerce (_, e, _) -> aux_can_skip ~can_skip_lambda e context
 
-    | Q.Path (_, _, _) ->
+    | Q.Path (_, _, _, _) ->
         failwith "Internal error: At this stage, all first-class paths should have been compiled."
 
     (* Concurrency-specific directive, and cps specific *)