[enhance] compiler, database: typing + code generation for the new wa…

…y to handles dbset

libqmlcompil/dbGen/dbGenHelpers.ml

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of OPA.
 
@@ -522,7 +522,7 @@ struct
   let typath = ti Opacapi.Types.badoplink_path
   let tytrans = ti Opacapi.Types.badoplink_transaction
   let tydbset ty =
-    ti ~param:[ty] Opacapi.Types.dbset ()
+    ti ~param:[ty] Opacapi.Types.db3set ()
   let tykey = ti Opacapi.Types.badoplink_db_path_key
   let typartialkey = ti Opacapi.Types.badoplink_db_partial_key
   let tydata = ti Opacapi.Types.badoplink_data_d

libqmlcompil/dbGen/dbGen_common.ml

@@ -77,32 +77,39 @@ module Args = struct
 
   let assoc = [("mongo", `mongo); ("db3"), `db3]
 
-  let r = ref default
+  let r = ref None
 
   let options = [
-    ("--database", Arg.spec_fun_of_assoc (fun s -> r := {engine=s}) assoc,
+    ("--database", Arg.spec_fun_of_assoc
+       (fun s -> r := Some {engine=s}) assoc,
      "Select kind of database (db3|mongo)");
   ]
 
-  let get_engine () = !r.engine
-
-  let set_engine e = r := { engine = e }
+  let get_engine () = Option.map (fun r -> r.engine) !r
 
 end
 
+let get_default () =
+  (Option.default {Args.engine = Args.default.Args.engine} !Args.r).Args.engine
+
+let get_engine, set_engine =
+  let engine = ref None in
+  (fun () -> Option.default (get_default ()) !engine),
+  (fun e -> engine := Some e)
+
 let settyp, typ =
   let typ = ref (function _ ->
                    OManager.i_error "Function for name -> TypeIdent.t translation is not initialized") in
   (function f -> typ := f),
   (function s -> !typ s)
 
 (* type of sets stored in the database *)
-let tydbset ty = QmlAst.TypeName ([ty], typ Opacapi.Types.dbset)
+let tydbset ty tyengine = QmlAst.TypeName ([ty; tyengine], Ident.source(Opacapi.Types.dbset))
 
 (** Extract the type inside a dbset type [get_dbset_ty(dbset(t)) = t]. *)
 let get_dbset_ty = function
-  | QmlAst.TypeName ([x], id) ->
-      assert(QmlAst.TypeIdent.to_string id = "dbset"); x
+  | QmlAst.TypeName ([x; _], _id) ->
+      x
   | ty -> OManager.i_error "Wait a dbset type receive : %a" QmlPrint.pp#ty ty
 
 let firstclass_path_tyid () =
@@ -148,18 +155,26 @@ module Db = struct
 
   let t () =
     let ident =
-      match Args.get_engine() with
+      match get_engine() with
       | `db3 -> Opacapi.Types.Db3.t
       | `mongo -> Opacapi.Types.DbMongo.t
     in
     QmlAst.TypeName ([], typ ident)
 
+  let set ty =
+    let ident =
+      match get_engine() with
+      | `db3 -> Opacapi.Types.db3set
+      | `mongo -> Opacapi.Types.dbmongoset
+    in
+    QmlAst.TypeName ([ty], typ ident)
+
   let mongo_engine () =
     QmlAst.TypeName ([], typ Opacapi.Types.DbMongo.engine)
 
   let ref_path_ty tydata =
     let tyengine =
-      match Args.get_engine() with
+      match get_engine() with
       | `db3 -> ref_path_ty tydata
       | `mongo -> mongo_engine ()
     in
@@ -169,7 +184,7 @@ module Db = struct
                     )
   let val_path_ty tydata =
     let tyengine =
-      match Args.get_engine() with
+      match get_engine() with
       | `db3 -> val_path_ty tydata
       | `mongo -> mongo_engine ()
     in

libqmlcompil/dbGen/dbGen_private.ml

@@ -1392,7 +1392,7 @@ module CodeGenerator ( Arg : DbGenByPass.S ) = struct
               in
               let merge_with_idents idents =
                 StringListMap.find point
-                  (R.fold merge (StringListMap.singleton point idents))
+                  (R.fold ~optional:true merge (StringListMap.singleton point idents))
               in
               let dbinfo, gamma, more_defs, partial_idents =
                 setup_db_accessors gamma db_def.Schema_private.schema db_ident db_diff_id merge_with_idents

libqmlcompil/dbGen/schema_private.ml

@@ -450,7 +450,8 @@ let add_path ~context gamma t path0 ty =
           build t next_node path
       | (Db.Decl_set lidx)::[] ->
           let t,n = SchemaGraphLib.set_node_label t n C.Multi in
-          let t,n = SchemaGraphLib.set_node_type t n (C.tydbset ty) in
+          let t,n = SchemaGraphLib.set_node_type t n
+            (C.tydbset ty (Q.TypeVar (QmlAst.TypeVar.next ()))) in
           add_subgraph ~is_plain:true ~context gamma t n (C.Multi_edge (C.Kfields lidx)) ty
       | (Db.Decl_set [])::_path ->
           QmlError.error context
@@ -703,7 +704,7 @@ let register_new_db_value ~name_default_values t gamma (label, value) =
                              context;
                              path_aliases = [];
                              options = {
-                               Q.Db.backend = C.Args.get_engine ();
+                               Q.Db.backend= C.get_default ();
                              };
                              schema = SchemaGraphLib.initial_schema ~context;
                              package = ObjectFiles.get_current_package_name ();
@@ -995,13 +996,7 @@ let rec convert_dbpath ~context t gamma node kind path0 path =
           | _ ->
               invalid_entry "key" (Format.to_string QmlPrint.pp#expr e)
         in
-        let keytyp = match e with
-        | Q.Record (_, keys) ->
-            (* Keys can be partial on syntaxical record. *)
-            let tykeys = fst (SchemaGraphLib.type_of_partial_key keys t node) in
-            Q.TypeRecord (QmlAstCons.Type.Row.make ~extend:false tykeys)
-        | _ -> SchemaGraphLib.type_of_key t node in
-
+        let keytyp = SchemaGraphLib.type_of_key t node in
         let new_annots, e = match e with
           | Q.Coerce (_, _,ty) when ty = keytyp -> [], e
           | e ->
@@ -1066,7 +1061,8 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
       find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node) ~kind ~epath0 vpath path
   | [], C.Multi -> (
       match node.C.ty with
-      | Q.TypeName ([setparam], name) as ty when Q.TypeIdent.to_string name = "dbset" ->
+      | Q.TypeName ([setparam;_], name) when Q.TypeIdent.to_string name = "dbset" ->
+          let ty = C.Db.set setparam in
           ty, node, `virtualset (setparam, ty, true, None)
       | ty -> ty, node, `realpath
     )
@@ -1087,10 +1083,10 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
        | [] -> ()
        | _ -> QmlError.error context "Path after queries is not yet allowed");
       (match setty with
-       | Q.TypeName ([setparam], name)
-           when Q.TypeIdent.to_string name = "dbset" ->
+       | Q.TypeName ([setparam; _], name) when Q.TypeIdent.to_string name = "dbset" ->
+           let setty = C.Db.set setparam in
            let node, partial, tyread = node, not (is_uniq t node query), setty in
-           node.C.ty, node, `virtualset (setparam, tyread, partial, None)
+           setty, node, `virtualset (setparam, tyread, partial, None)
        | _ ->
            let keyty = SchemaGraphLib.type_of_key t node in
            let partial = not (is_uniq t node query) in
@@ -1191,7 +1187,7 @@ let preprocess_kind ~context gamma kind ty virtual_ =
 
 let preprocess_path ~context t gamma prepath kind =
   let prefix, db_def, prepath = database_def_of_path_expr ~context t prepath in
-  C.Args.set_engine db_def.options.Db.backend;
+  C.set_engine db_def.options.Db.backend;
   let prepath = apply_aliases db_def.path_aliases prepath in
   let root = SchemaGraphLib.get_root db_def.schema in
   let new_annots, epath = convert_dbpath ~context db_def.schema gamma root kind prepath prepath in

libqmlcompil/qmlDbGen.mli

@@ -28,8 +28,8 @@ module Args : sig
   (** The command line specifications. *)
   val options : (string * Base.Arg.spec * string) list
 
-  (** Get selected backend.*)
-  val get_engine : unit -> engine
+  (** Get command line backend.*)
+  val get_engine : unit -> engine option
 
 end
 

opa/main.ml

@@ -156,6 +156,7 @@ let () =
 
     |?> (If.database `db3,
          "BadopCodeGeneration", S3.pass_BadopCodeGeneration)
+
     |?> (If.database `mongo,
          "MongoCodeGeneration", S3.pass_MongoCodeGeneration)
 

opa/pass_DbEngineImportation.ml

@@ -54,10 +54,15 @@ let import_packages engine =
 
 let process_code ~stdlib code =
   if stdlib then
+    let engines =
+      match QmlDbGen.Args.get_engine () with
+      | None -> []
+      | Some engine -> [engine]
+    in
     let engines =
       R.fold_with_name ~deep:true
         (fun _ acc t -> t@acc)
-        []
+        engines
     in
     let engines = List.fold_left
       (fun acc -> function

opa/pass_MongoAccessGeneration.ml

@@ -566,7 +566,14 @@ module Generator = struct
       match kind with
       | DbAst.Default | DbAst.Option ->
           (match setkind, uniq with
-           | DbSchema.DbSet _, false -> (annotmap, set)
+           | DbSchema.DbSet ty, false ->
+               let annotmap, iterator =
+                 OpaMapToIdent.typed_val ~label
+                   ~ty:[ty]
+                   Api.DbSet.iterator annotmap gamma in
+               let annotmap, iterator =
+                 C.apply ~ty gamma annotmap iterator [set] in
+               C.record annotmap [("iter", iterator); ("engine", set)]
            | DbSchema.Map (keyty, dataty), false ->
                let (annotmap, to_map) =
                  OpaMapToIdent.typed_val ~label

opacapi/opacapi.ml

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of OPA.
 
@@ -168,6 +168,7 @@ struct
   let add_to_document = !! "add_to_document"
   let indexes = !! "indexes"
   let to_map = !! "to_map"
+  let iterator = !! "iterator"
   let map_to_uniq = !! "map_to_uniq"
   let set_to_uniq = !! "set_to_uniq"
   let map_to_uniq_def = !! "map_to_uniq_def"
@@ -322,6 +323,8 @@ struct
   let continuation = !! "continuation"
   let dbgraph_diff = !! "dbgraph_diff"
   let dbset = !! "dbset"
+  let db3set = !! "Db3Set.t"
+  let dbmongoset = !! "DbMongoSet.t"
   let dom = !! "dom"
   let finite_single_thread_lazy = !! "finite_single_thread_lazy"
   let float = !! "float"

qmlpasses/pass_DbAccessorsGeneration.ml

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of OPA.