Skip to content
Browse files

[fix] compiler, database: Adding all database ident to gamma, even if…

… no explicit declaration
  • Loading branch information...
1 parent 41e6e11 commit 4b041c8f9603f936f9c5ec71616e3186c5517a58 @BourgerieQuentin BourgerieQuentin committed Feb 15, 2012
View
18 libqmlcompil/dbGen/schema_private.ml
@@ -79,6 +79,7 @@ type edge = SchemaGraphLib.SchemaGraph0.edge
type database_def = {
ident: Q.ident;
+ ty:Q.ty;
context: QmlError.context;
path_aliases: (Q.path * Q.path) list;
(* eg. [(/a,/b); (/alias,/deep/data)] *)
@@ -697,6 +698,7 @@ let register_new_db_value ~name_default_values t gamma (label, value) =
(* No database declaration found, so add the schema for the default db.
Note that the db identifier is then not user-accessible. *)
StringListMap.add [] { ident = Ident.next "database";
+ ty = C.Db.t ();
context;
path_aliases = [];
options = [];
@@ -737,33 +739,31 @@ let register_new_db_value ~name_default_values t gamma (label, value) =
Some (binding, Db.Db_Virtual (p, e)) in
s, new_value
-let register_db_declaration t gamma (label, ident, p, opts) =
+let register_db_declaration t (label, ident, p, opts) =
let context = QmlError.Context.code_elt (Q.Database (label, ident, p, opts)) in
let context = HacksForPositions.map context in
let error msg =
QmlError.i_error None context msg
in
- let (database_type, _) = QmlTypes.type_of_type gamma (C.Db.t ()) in
- let gamma =
- QmlTypes.Env.Ident.add ident (QmlTypes.Scheme.quantify database_type) gamma
- in
begin match p with
| [] ->
(StringListMap.add [] { ident = ident;
+ ty = C.Db.t ();
context = context;
path_aliases = [];
options = opts;
schema = SchemaGraphLib.initial_schema ~context;
virtual_path = PathMap.empty;
- } t, gamma)
+ } t)
| [Db.Decl_fld point] ->
(StringListMap.add [point] { ident = ident;
+ ty = C.Db.t ();
context = context;
path_aliases = [];
options = opts;
schema = SchemaGraphLib.initial_schema ~context;
virtual_path = PathMap.empty;
- } t, gamma)
+ } t)
| _ -> error "Unhandled DB definition"
end
@@ -774,8 +774,8 @@ let get_db_declaration t =
StringListMap.fold
(fun name decl acc ->
match name with
- | [name] -> (decl.ident, name, decl.options)::acc
- | [] -> (decl.ident, "_no_name", decl.options)::acc
+ | [name] -> (decl, name)::acc
+ | [] -> (decl, "_no_name")::acc
| _ -> get_error decl "Unhandled Db definition"
)
t []
View
22 libqmlcompil/qmlDbGen.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -41,6 +41,8 @@ module Schema = struct
type database = {
name : string;
ident : Ident.t;
+ dbty : QmlAst.ty;
+ options : QmlAst.Db.options list;
package : ObjectFiles.package_name;
}
@@ -113,6 +115,7 @@ module Schema = struct
let from_gml s =
StringListMap.singleton []
({ Sch.ident = Ident.next "dummy_from_gml";
+ Sch.ty = C.Db.t ();
Sch.context = QmlError.Context.pos (FilePos.nopos "built from gml");
Sch.path_aliases = [];
Sch.options = [];
@@ -142,18 +145,25 @@ module Schema = struct
let _, db_def = find_db_def t db_ident_opt in
Schema_io.to_gml db_def.Sch.schema chan
- let get_db_declaration = Sch.get_db_declaration
-
let db_declaration = Sch.db_declaration
- let get_database schema name =
- let declaration = db_declaration schema name in
+ let decl_to_db name decl =
{
name;
- ident = declaration.Sch.ident;
+ ident = decl.Sch.ident;
+ dbty = decl.Sch.ty;
+ options = decl.Sch.options;
package = "todo" (*TODO*);
}
+ let get_db_declaration schema =
+ let decls = Sch.get_db_declaration schema in
+ List.map (fun (decl, name) -> decl_to_db name decl) decls
+
+ let get_database schema name =
+ let declaration = db_declaration schema name in
+ decl_to_db name declaration
+
exception Vertex of Graph.vertex
let get_root schema = try
View
11 libqmlcompil/qmlDbGen.mli
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -50,6 +50,8 @@ module Schema: sig
type database = {
name : string;
ident : Ident.t;
+ dbty : QmlAst.ty;
+ options : QmlAst.Db.options list;
package : ObjectFiles.package_name;
}
@@ -115,9 +117,8 @@ module Schema: sig
(** Registers database declarations *)
val register_db_declaration:
- t -> QmlTypes.Env.t
- -> Annot.label * Ident.t * QmlAst.Db.path_decl * QmlAst.Db.options list
- -> t * QmlTypes.Env.t
+ t -> Annot.label * Ident.t * QmlAst.Db.path_decl * QmlAst.Db.options list
+ -> t
(** Registers db-related declarations (paths & default & constraints)
See register_default for the meaning of the name_default_values parameter
@@ -179,7 +180,7 @@ module Schema: sig
(** Parses a schema saved in the GML format (like in the run-time db) *)
val from_gml: string -> t
- val get_db_declaration: t -> (QmlAst.ident * string * QmlAst.Db.options list) list
+ val get_db_declaration: t -> database list
val get_node: t -> QmlAst.path -> node
View
8 opa/pass_MongoAccessGeneration.ml
@@ -653,16 +653,18 @@ end
let init_database gamma annotmap schema =
List.fold_left
- (fun (annotmap, newvals) (ident, name, opts) ->
- match opts with
+ (fun (annotmap, newvals) database ->
+ let ident = database.DbSchema.ident in
+ let name = database.DbSchema.name in
+ match database.DbSchema.options with
| [`engine (`client (host, port))] ->
let (annotmap, open_) = Generator.open_database gamma annotmap name host port in
(annotmap, (Q.NewVal (label, [ident, open_]))::newvals)
| _ ->
let (annotmap, open_) = Generator.open_database gamma annotmap name None None in
(annotmap, (Q.NewVal (label, [ident, open_]))::newvals)
)
- (annotmap, []) (QmlDbGen.Schema.get_db_declaration schema)
+ (annotmap, []) (DbSchema.get_db_declaration schema)
let clean_code gamma annotmap schema code =
List.fold_left_filter_map
View
7 opatop/opaTopEnv.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -255,13 +255,12 @@ let input_code_elt_Database env database =
| Q.Database (label, ident, p, opts) -> (
match env.schema with
| Building schema ->
- let (schema, gamma) =
- Schema.register_db_declaration schema env.env_types.QmlTypes.gamma (label, ident, p, opts)
+ let schema =
+ Schema.register_db_declaration schema (label, ident, p, opts)
in
{ env with
schema = Building schema ;
open_db = true ;
- env_types = { env.env_types with QmlTypes.gamma = gamma } ;
}
| _ ->
OManager.error
View
1 qmlpasses/_tags
@@ -11,3 +11,4 @@
<pass_Closure.{ml,mli}>: with_mlstate_debug, use_jslang
<pass_ConstantSharing.ml>: with_mlstate_debug
<pass_GenerateServerAst.ml>: with_mlstate_debug, use_jslang
+<pass_DbSchemaGeneration.ml> : with_mlstate_debug
View
35 qmlpasses/pass_DbSchemaGeneration.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -19,6 +19,8 @@
module List = BaseList
+module DbSchema = QmlDbGen.Schema
+
module Arg =
struct
module A = Base.Arg
@@ -163,16 +165,14 @@ let process_code gamma _annotmap schema code =
The construction of the schema needs to get
Database nodes before NewDbValue.
*)
- let (schema, gamma) =
+ let schema =
List.fold_left
- (fun ((schema, gamma) as acc) code_elt ->
+ (fun schema code_elt ->
match code_elt with
| QmlAst.Database (label, ident, p, opts) ->
- QmlDbGen.Schema.register_db_declaration
- schema gamma (label, ident, p, opts)
- | _ -> acc
- ) (schema, gamma) code in
-
+ QmlDbGen.Schema.register_db_declaration schema (label, ident, p, opts)
+ | _ -> schema
+ ) schema code in
(* registering NewDbValue definitions *)
let schema, code =
List.fold_left_collect (
@@ -226,6 +226,25 @@ let process_code gamma _annotmap schema code =
| None -> schema, schema (* empty schemas *)
in
+ (* updating gamma with registered databases *)
+ let gamma =
+ match ObjectFiles.compilation_mode () with
+ | `init -> gamma
+ | _ ->
+ List.fold_left
+ (fun gamma database ->
+ let ty = fst (QmlTypes.type_of_type gamma (database.DbSchema.dbty)) in
+ let _ =
+ #<If:DBGEN_DEBUG>
+ OManager.printf "Adding database (%a) %a to gamma\n%!"
+ QmlPrint.pp#ty ty
+ QmlPrint.pp#ident database.DbSchema.ident
+ #<End>;
+ in
+ QmlTypes.Env.Ident.add database.DbSchema.ident (QmlTypes.Scheme.quantify ty) gamma)
+ gamma (DbSchema.get_db_declaration schema)
+ in
+
let _ = R.save partial_schema in
let _ = auto_disp_schema schema in

0 comments on commit 4b041c8

Please sign in to comment.
Something went wrong with that request. Please try again.