Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

[enhance] compiler: (big) added mongo accessors generation + database…

… backend switch
  • Loading branch information...
commit ccded04a1e4b5243a3ba2240aba5584b45fd97de 1 parent 1ad3df2
@BourgerieQuentin BourgerieQuentin authored
View
1  opa/_tags
@@ -15,6 +15,7 @@
<pass_FunActionEnvSerialize.{ml,mli}>: use_libqmlcompil, use_opalang, use_opalib, use_jslang, use_qmlpasses
<pass_FunActionJsCallGeneration.{ml,mli}>: use_libqmlcompil, use_opalang, use_opalib, use_qml2js
<opa_InsertRemote.{ml,mli}>: use_libqmlcompil, use_opalib, use_qmlpasses, use_jslang
+<pass_MongoAccessGeneration.{ml,mli}>: use_libqmlcompil, use_opalang, use_qmlpasses
<pass_RegisterFields.{ml,mli}>: use_libqmlcompil
<opa_SlicedReorder.{ml,mli}>: use_libqmlcompil, use_opalib
<pass_AddCSS.{ml,mli}>: use_libqmlcompil, use_opalib, use_opalang
View
9 opa/main.ml
@@ -28,10 +28,12 @@ let (|>) = PH.(|>)
let (<?>) = PH.(<?>)
let (&) = PH.(&)
let (|?>) = PH.(|?>)
+let (|?|) = PH.(|?|)
let (or) = PH.(or)
(* Shorthands for accessing options of compilation *)
module If = Main_utils.If
+module Switch = Main_utils.Switch
(* The deprecated passes *)
(* FIXME: adapt to the new PassHandler *)
@@ -152,9 +154,10 @@ let () =
(*|+> ("Retyping", S3.pass_Retyping)*)
- |+> ("DbAccessorsGeneration", S3.pass_DbAccessorsGeneration)
-
- |+> ("DbCodeGeneration", S3.pass_DbCodeGeneration)
+ |?| ( Switch.database, function
+ | QmlDbGen.Db3 -> ("BadopCodeGeneration", S3.pass_BadopCodeGeneration)
+ | QmlDbGen.Mongo -> ("MongoCodeGeneration", S3.pass_MongoCodeGeneration)
+ )
(* could be just after typing, if dbgen didn't complain that it can't find its coercions :/ *)
|+> ("PurgeTypeDirectivesAfterTyping", S3.pass_PurgeTypeDirectiveAfterTyping)
View
7 opa/main_utils.ml
@@ -69,5 +69,12 @@ struct
let i18n_template ~options _env = E.i18n_template options
end
+module Switch =
+struct
+ let database ~options _env =
+ ignore options;
+ QmlDbGen.Args.get_engine ()
+end
+
let if_not f_cond ~options env = not (f_cond ~options env)
let if_and f_cond1 f_cond2 ~options env = (f_cond1 ~options env) && (f_cond2 ~options env)
View
273 opa/pass_MongoAccessGeneration.ml
@@ -0,0 +1,273 @@
+(* shorthands *)
+module Q = QmlAst
+module C = QmlAstCons.TypedExpr
+
+module Api = Opacapi
+
+module DbAst = QmlAst.Db
+module DbSchema = QmlDbGen.Schema
+module List = BaseList
+
+type db_access = {
+ engines : Ident.t StringMap.t
+}
+
+let label = Annot.nolabel "MongoAccessGeneration"
+
+
+module Generator = struct
+
+ let ty_database = Q.TypeVar (QmlTypeVars.TypeVar.next ())
+
+ let open_database gamma annotmap host port =
+ let (annotmap, name) = C.string annotmap "test" in
+ let (annotmap, host) = C.string annotmap host in
+ let (annotmap, port) = C.int annotmap port in
+ let (annotmap, open_) = OpaMapToIdent.typed_val ~label Opacapi.Db.open_ annotmap gamma in
+ let (annotmap, open_) = C.apply gamma annotmap open_ [name; host; port] in
+ (annotmap, open_)
+
+ let rec compose_path gamma annotmap schema kind subs =
+ ignore (match kind with
+ | DbAst.Ref -> assert false
+ | _ -> kind);
+ let annotmap, subs =
+ List.fold_left_map
+ (fun annotmap (field, sub) ->
+ let (annotmap, path) = string_path gamma annotmap schema (DbAst.Valpath, sub) in
+ annotmap, (field, path))
+ annotmap subs
+ in
+ let annotmap, read =
+ let annotmap, res =
+ let (annotmap, subsread) = List.fold_left_map
+ (fun annotmap (field, subpath) ->
+ let (annotmap, read) =
+ OpaMapToIdent.typed_val ~label Api.Db.read annotmap gamma in
+ let (annotmap, read) = C.apply gamma annotmap read [subpath] in
+ annotmap, (field, read)
+ ) annotmap subs
+ in C.record annotmap subsread
+ in
+ let annotmap, res = C.record annotmap [("some", res)] in
+ C.lambda annotmap [] res
+ in
+ let annotmap, more = C.cheap_void annotmap gamma in
+ let pathty = Api.Types.val_path in
+ (annotmap, [read; more], Api.Db.build_path_raw, pathty)
+
+ and string_path gamma annotmap schema (kind, strpath) =
+ (* vv FIXME !?!?! vv *)
+ let (annotmap2, node) =
+ let strpath = List.map (fun k -> DbAst.FldKey k) strpath in
+ DbSchema.get_node annotmap schema strpath in
+ let annotmap = QmlAnnotMap.merge annotmap annotmap2 in
+ (* ^^ FIXME !?!?! ^^ *)
+
+ let (annotmap, args, builder, pathty) =
+ match node.DbSchema.kind with
+ | DbSchema.Compose subs ->
+ compose_path gamma annotmap schema kind subs
+
+ | DbSchema.Partial (rpath, partial) ->
+ let annotmap, partial = C.list_map
+ (fun annotmap fragment -> C.string annotmap fragment)
+ (annotmap, gamma) partial
+ in let annotmap, rpath = C.list_map
+ (fun annotmap fragment -> Printf.eprintf "%s\n%!" fragment; C.string annotmap fragment)
+ (annotmap, gamma) rpath
+ in annotmap, [rpath; partial], Api.Db.build_vpath_sub, Api.Types.val_path
+ | DbSchema.Plain ->
+ (match kind with
+ | DbAst.Update _
+ | DbAst.Ref -> (annotmap, [], Api.Db.build_rpath, Api.Types.ref_path)
+ | _ -> (annotmap, [], Api.Db.build_vpath, Api.Types.val_path))
+ | _ -> assert false
+ in
+ let dbname, strpath =
+ match strpath with
+ | k::path -> (k, path)
+ | _ -> assert false
+ in
+ let (annotmap, path) = List.fold_left
+ (fun (annotmap, acc) key ->
+ let annotmap, e = C.string annotmap key in
+ annotmap, e::acc
+ ) (annotmap, []) strpath
+ in
+ let dataty = node.DbSchema.ty in
+ let (annotmap, build) =
+ OpaMapToIdent.typed_val ~label ~ty:[dataty] builder annotmap gamma in
+ let (annotmap, path) = C.rev_list (annotmap, gamma) path in
+ let (annotmap, database) =
+ let (database, _) =
+ try
+ QmlDbGen.Schema.db_declaration schema dbname
+ with Not_found ->
+ OManager.i_error "\"%s\" database declaration was not found on database schema" dbname
+ in
+ C.ident annotmap database ty_database
+ in
+ let ty = OpaMapToIdent.specialized_typ ~ty:[dataty] pathty gamma in
+ let (annotmap, path) = C.apply ~ty gamma annotmap build
+ ([database; path; node.DbSchema.default] @ args) in
+ let again =
+ match kind with
+ | DbAst.Default -> Some Api.Db.read
+ | DbAst.Option -> Some Api.Db.option
+ | _ -> None
+ in
+ let (annotmap, path) =
+ match again with
+ | None -> (annotmap, path)
+ | Some again ->
+ let (annotmap, again) =
+ OpaMapToIdent.typed_val ~label ~ty:[QmlAstCons.Type.next_var (); dataty]
+ again annotmap gamma in
+ C.apply gamma annotmap again [path]
+ in match kind with
+ | DbAst.Update u -> (
+ match u with
+ | DbAst.UExpr e ->
+ let (annotmap, write) =
+ OpaMapToIdent.typed_val ~label ~ty:[dataty] Api.Db.write annotmap gamma in
+ C.apply gamma annotmap write [path; e]
+ )
+ | _ -> annotmap, path
+
+ let query_to_expr gamma annotmap query =
+ let rec aux annotmap query =
+ match query with
+ | DbSchema.Empty -> C.list (annotmap, gamma) []
+ | _ -> assert false
+ in aux annotmap query
+
+ let update_to_expr gamma annotmap update =
+ let rec aux annotmap update =
+ match update with
+ | DbAst.UExpr e ->
+ let a = Annot.annot (QmlAst.Label.expr e) in
+ let ty = QmlAnnotMap.find_ty a annotmap in
+ match ty with
+ | QmlAst.TypeRecord _ ->
+ let (annotmap, opa2doc) =
+ OpaMapToIdent.typed_val ~label ~ty:[ty] Api.DbSet.opa2doc annotmap gamma
+ in
+ C.apply gamma annotmap opa2doc [e]
+ | _ -> assert false
+ (* | _ -> assert false *)
+ in aux annotmap update
+
+ let dbset_path gamma annotmap schema (kind, path) node query =
+ let ty = node.DbSchema.ty in
+ let dbname = node.DbSchema.database.DbSchema.name in
+ (* DbSet.build *)
+ let (annotmap, build, args) =
+ (match kind with
+ | DbAst.Default ->
+ let tydbset = OpaMapToIdent.typ Api.Types.dbset in
+ let dataty =
+ match ty with
+ | Q.TypeName ([dataty], tyident) when Q.TypeIdent.compare tydbset tyident = 0
+ -> dataty
+ | _ -> assert false
+ in
+ let (annotmap, build) =
+ OpaMapToIdent.typed_val ~label ~ty:[dataty] Api.DbSet.build annotmap gamma in
+ (annotmap, build, [])
+ | DbAst.Update u ->
+ let (annotmap, update) = update_to_expr gamma annotmap u in
+ let (annotmap, build) =
+ OpaMapToIdent.typed_val ~label Api.DbSet.update annotmap gamma
+ in
+ (annotmap, build, [update])
+ | _ -> assert false)
+ in
+ (* database *)
+ let (annotmap, database) =
+ let (database, _) =
+ try
+ QmlDbGen.Schema.db_declaration schema dbname
+ with Not_found ->
+ OManager.i_error "\"%s\" database declaration was not found on database schema" dbname
+ in
+ C.ident annotmap database ty_database
+ in
+ (* path : list(string) *)
+ let (annotmap, path) =
+ let (annotmap, path) = List.fold_left
+ (fun (annotmap, acc) key ->
+ let annotmap, e = C.string annotmap key in
+ annotmap, e::acc
+ ) (annotmap, []) path
+ in
+ C.rev_list (annotmap, gamma) path in
+ (* query *)
+ let (annotmap, query) = query_to_expr gamma annotmap query in
+ (* dbset = DbSet.build(database, path, query) *)
+ let (annotmap, set) = C.apply ~ty gamma annotmap build ([database; path; query] @ args) in
+ (annotmap, set)
+
+ let path gamma annotmap schema (kind, dbpath) =
+ let (_, node) = DbSchema.get_node annotmap schema dbpath in
+ Format.eprintf "%a\n%!" DbSchema.pp_node node;
+ match node.DbSchema.kind with
+ | DbSchema.SetAccess (path, _, query) ->
+ dbset_path gamma annotmap schema (kind, path) node query
+ | _ ->
+ let strpath = List.map
+ (function
+ | DbAst.FldKey k -> k
+ | _ -> assert false
+ ) dbpath in
+ string_path gamma annotmap schema (kind, strpath)
+
+end
+
+let init_database gamma annotmap schema =
+ List.fold_left
+ (fun (annotmap, newvals) (ident, _name, opts) ->
+ match opts with
+ | [`engine (`client (Some host, Some port))] ->
+ let (annotmap, open_) = Generator.open_database gamma annotmap host port in
+ (annotmap, (Q.NewVal (label, [ident, open_]))::newvals)
+ | _ ->
+ let (annotmap, open_) = Generator.open_database gamma annotmap "localhost" 27017 in
+ (annotmap, (Q.NewVal (label, [ident, open_]))::newvals)
+ )
+ (annotmap, []) (QmlDbGen.Schema.get_db_declaration schema)
+
+let clean_code code =
+ List.filter
+ (function
+ | Q.Database _ -> false
+ | Q.NewDbValue _ -> false
+ | _ -> true)
+ code
+
+let process_path gamma annotmap schema code =
+ let fmap tra annotmap = function
+ | Q.Path (_label, path, kind) ->
+ Generator.path gamma annotmap schema (kind, path)
+ | e -> tra annotmap e
+ in
+ QmlAstWalk.CodeExpr.fold_map
+ (fun annotmap expr ->
+ let annotmap, expr = QmlAstWalk.Expr.traverse_foldmap fmap annotmap expr in
+ fmap (fun a e -> a,e) annotmap expr)
+ annotmap code
+
+
+let process_code ~stdlib_gamma gamma annotmap schema code =
+ match ObjectFiles.compilation_mode () with
+ | `init -> (annotmap, code)
+ | _ ->
+ let code = clean_code code in
+ let (annotmap, code) =
+ let (annotmap, vals) = init_database stdlib_gamma annotmap schema in
+ (annotmap, vals@code)
+ in
+ let gamma = QmlTypes.Env.unsafe_append stdlib_gamma gamma in
+ let (annotmap, code) = process_path gamma annotmap schema code in
+ (annotmap, code)
+
View
44 opa/s3Passes.ml
@@ -910,7 +910,7 @@ let pass_DbSchemaGeneration =
in
PassHandler.make_pass ~precond ~postcond ~invariant
(fun e ->
- QmlDbGen.settyp OpaMapToIdent.typ;
+ QmlDbGen.settyp OpaMapToIdent.typ;
let env = ( e.PH.env : 'tmp_env Passes.env_Gen ) in
let typerEnv = env.Passes.typerEnv in
let code = env.Passes.qmlAst in
@@ -1015,7 +1015,7 @@ let pass_WarnCoerce =
)
let pass_CompileRecursiveValues =
- PassHandler.make_pass
+ PassHandler.make_pass ~invariant
(fun e ->
let env = (e.PH.env : 'tmp_env Passes.env_Gen) in
let typerEnv = env.Passes.typerEnv in
@@ -1032,7 +1032,7 @@ let pass_CompileRecursiveValues =
)
let pass_RewriteAsyncLambda =
- PassHandler.make_pass
+ PassHandler.make_pass ~invariant
(fun e ->
let env = (e.PH.env : 'tmp_env Passes.env_Gen) in
let typerEnv = env.Passes.typerEnv in
@@ -1046,33 +1046,39 @@ let pass_RewriteAsyncLambda =
{e with PH.env = env}
)
-let pass_DbAccessorsGeneration =
- let invariant = global_invariant () in
- let precond = [
- ] in
- let postcond = [
- QmlCheck.Annot.find Extract.EnvGen.ac ;
- ] in
- make_pass_raw_env_refresh Passes.pass_DbAccessorsGeneration
- ~invariant
- ~precond
- ~postcond
- ()
-
-let pass_DbCodeGeneration =
- let invariant = global_invariant () in
+let pass_BadopCodeGeneration =
let precond = [
] in
let postcond = [
CodeContents.only_NewVal Extract.EnvGen.ac ;
QmlCheck.Annot.find Extract.EnvGen.ac ;
] in
- make_pass_raw_env_refresh Passes.pass_DbCodeGeneration
+ let pass ~options e =
+ Passes.pass_DbCodeGeneration ~options (Passes.pass_DbAccessorsGeneration ~options e) in
+ make_pass_raw_env_refresh pass
~invariant
~precond
~postcond
()
+let pass_MongoCodeGeneration =
+ PassHandler.make_pass ~invariant
+ (fun e ->
+ let env = e.PH.env in
+ let typerEnv = env.Passes.typerEnv in
+ let gamma = typerEnv.QmlTypes.gamma in
+ let stdlib_gamma = env.Passes.stdlib_gamma in
+ let annotmap = typerEnv.QmlTypes.annotmap in
+ let schema = typerEnv.QmlTypes.schema in
+ let code = env.Passes.qmlAst in
+ let (nannotmap, code) =
+ Pass_MongoAccessGeneration.process_code ~stdlib_gamma gamma annotmap schema code in
+ let typerEnv = { typerEnv with QmlTypes.
+ gamma = gamma;
+ annotmap = nannotmap} in
+ { e with PH.env = {env with Passes.qmlAst = code; typerEnv = typerEnv;} }
+ )
+
let pass_DocApiGeneration =
make_pass_raw_env Pass_OpaDocApi.process_qml
~invariant ()
View
8 opa/s3Passes.mli
@@ -275,11 +275,11 @@ val pass_Retyping :
val pass_PurgeTypeDirectiveAfterTyping :
(unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
-val pass_DbAccessorsGeneration :
- (unit Passes.env_Gen, (QmlDbGen.dbinfo StringListMap.t * QmlAlphaConv.t option) Passes.env_Gen) opa_pass
+val pass_BadopCodeGeneration :
+ (unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
-val pass_DbCodeGeneration :
- ((QmlDbGen.dbinfo StringListMap.t * QmlAlphaConv.t option) Passes.env_Gen, unit Passes.env_Gen) opa_pass
+val pass_MongoCodeGeneration :
+ (unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
val pass_DocApiGeneration :
(unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
View
46 opacapi/opacapi.ml
@@ -128,6 +128,30 @@ struct
let set = !! "set"
end
+module Db =
+struct
+ let (!!) s = !! ("Db_" ^ s)
+ let open_ = !! "open"
+ let build_path_raw = !! "build_path_raw"
+ let build_vpath = !! "build_vpath"
+ let build_vpath_sub = !! "build_vpath_sub"
+ let build_rpath = !! "build_rpath"
+ let option = !! "option"
+ let read = !! "read"
+ let write = !! "write"
+end
+
+module DbSet =
+struct
+ let (!!) s = !! ("DbSet_" ^ s)
+ let build = !! "build"
+ let update = !! "update"
+ let empty = !! "empty"
+ let opa2doc = !! "opa2doc"
+ let add_to_document = !! "add_to_document"
+ let indexes = !! "indexes"
+end
+
module Opa2Js =
struct
let (!!) s = !! ("Opa2Js_" ^ s)
@@ -291,6 +315,8 @@ struct
let path_ref_p = !! "path_ref_p"
let path_t = !! "path_t"
let path_val_p = !! "path_val_p"
+ let val_path = !! "val_path"
+ let ref_path = !! "ref_path"
let string = !! "string"
let stringmap = !! "stringmap"
@@ -307,6 +333,12 @@ struct
let xhtml_href = !! "xhtml_href"
let xml = !! "xml"
+ (* module Bson = *)
+ (* struct *)
+ (* let (!!) s = !! ("Bson." ^ s) *)
+ (* let document = !! "document" *)
+ (* end *)
+
module Cell =
struct
let (!!) s = !! ("Cell." ^ s)
@@ -333,6 +365,12 @@ struct
let future = !! "future"
end
+ module DbSet =
+ struct
+ let (!!) s = !! ("DbSet." ^ s)
+ let query = !! "query"
+ end
+
module Deprecated =
struct
let (!!) s = !! ("Deprecated." ^ s)
@@ -427,14 +465,6 @@ struct
end
end
- (*module Bson =
- struct
- let (!!) s = !! ("Bson." ^ s)
- let document = !! "document"
- let element = !! "element"
- let value = !! "value"
- end*)
-
module ThreadContext =
struct
let (!!) s = !! ("ThreadContext." ^ s)
View
32 qmlpasses/pass_DbSchemaGeneration.ml
@@ -53,22 +53,22 @@ struct
let options = [
- "--database",
- A.String (fun s ->
- try
- let (name, opt_string) = BaseString.split_char '@' s in
- let point =
- if name = "" then []
- else [BaseString.remove_suffix ":" name]
- in
- let opts = parse_opts opt_string in
- commandline_override :=
- StringListMap.add point opts !commandline_override;
- ()
- with
- | Not_found -> failwith "Separate the name of the database and the options with a colon, e.g., --database 'db1:\"@shared(:4849)\"'."
- ),
- " Override options of a database";
+ (* "--database", *)
+ (* A.String (fun s -> *)
+ (* try *)
+ (* let (name, opt_string) = BaseString.split_char '@' s in *)
+ (* let point = *)
+ (* if name = "" then [] *)
+ (* else [BaseString.remove_suffix ":" name] *)
+ (* in *)
+ (* let opts = parse_opts opt_string in *)
+ (* commandline_override := *)
+ (* StringListMap.add point opts !commandline_override; *)
+ (* () *)
+ (* with *)
+ (* | Not_found -> failwith "Separate the name of the database and the options with a colon, e.g., --database 'db1:\"@shared(:4849)\"'." *)
+ (* ), *)
+ (* " Override options of a database"; *)
"--export-db-schema",
A.String (fun s ->
View
3  qmlpasses/pass_ExplicitInstantiation.ml
@@ -1377,6 +1377,9 @@ let process_code (have_typeof:QmlTypeVars.FreeVars.t) gamma annotmap _published
QmlAnnotMap.find_tsc_opt (Q.QAnnot.expr e) annotmap in
match tsc with
| None ->
+ #<If:EXPL_INST_DEBUG>
+ debug "Generalization no typescheme for %a" pp#ident id
+ #<End>;
(* no type variables in the schema, no type arguments needed *)
((annotmap, e), ajax_ast)
| Some tsc ->
View
2  stdlib/apis/mongo/collection.opa
@@ -148,7 +148,7 @@ MongoCollection = {{
if e.name == "_id"
then (z,o,g)
else
- match Bson.int_of_element(e) with
+ match Bson.int_of_element(e) with
| {some=0} -> (z+1,o,g)
| {some=1} -> (z,o+1,g)
| {some=_} | {none} -> (z,o,g+1)),
View
1  stdlib/apis/mongo/mongo.opa
@@ -93,7 +93,6 @@ type Mongo.srr =
@private type Mongo.reconnectmsg = {reconnect:(string,Mongo.db)} / {stop}
@private type Mongo.reconnectresult = {reconnectresult:bool} / {stopresult}
-@private
MongoDriver = {{
@private ML = MongoLog
View
3  stdlib/core/xhtml/xhtml.opa
@@ -863,6 +863,9 @@ Xhtml =
do Buf.add(js_buffer,"\n.css(\{ ")
iter_tell_me_if_i_am_last((~{name value}, last ->
do Buf.add(js_buffer,"'")
+
+
+
do Buf.add(js_buffer,name)
do Buf.add(js_buffer,"': '")
do Buf.add(js_buffer,value)
View
2  stdlib/database/db3/db.opa
@@ -86,6 +86,8 @@ type badoplink_revision = external
@opacapi type opa_transaction_t('a) = external
@opacapi type dbgraph_diff = external
+@opacapi Db_write = Db.write
+
/**
* Value paths
Please sign in to comment.
Something went wrong with that request. Please try again.