Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: MLstate/opalang
...
head fork: MLstate/opalang
Checking mergeability… Don't worry, you can still create the pull request.
  • 19 commits
  • 33 files changed
  • 0 commit comments
  • 2 contributors
Showing with 2,332 additions and 927 deletions.
  1. +1 −1  Makefile
  2. +22 −6 compiler/libqmlcompil/dbGen/dbGen_common.ml
  3. +2 −2 compiler/libqmlcompil/dbGen/dbGen_private.ml
  4. +113 −45 compiler/libqmlcompil/dbGen/schema_private.ml
  5. +82 −28 compiler/libqmlcompil/qmlAst.ml
  6. +105 −1 compiler/libqmlcompil/qmlAstWalk.ml
  7. +13 −1 compiler/libqmlcompil/qmlAstWalk.mli
  8. +34 −7 compiler/libqmlcompil/qmlDbGen.ml
  9. +7 −4 compiler/libqmlcompil/qmlDbGen.mli
  10. +2 −1  compiler/libqmlcompil/qmlDependencies.ml
  11. +1 −0  compiler/libtrx/pgrammar.ml
  12. +1 −0  compiler/opa/_tags
  13. +4 −1 compiler/opa/compiler.ml
  14. +3 −1 compiler/opa/pass_DbEngineImportation.ml
  15. +6 −6 compiler/opa/pass_DropBoxCodeGeneration.ml
  16. +9 −7 compiler/opa/pass_MongoAccessGeneration.ml
  17. +671 −0 compiler/opa/pass_PostgresCodeGeneration.ml
  18. +20 −1 compiler/opa/s3Passes.ml
  19. +4 −1 compiler/opa/s3Passes.mli
  20. +31 −6 compiler/opacapi/opacapi.ml
  21. +4 −3 compiler/opalang/classic_syntax/opa_parser.trx
  22. +89 −1 compiler/opalang/classic_syntax/parser_path.trx
  23. +3 −2 compiler/opalang/js_syntax/opa_parser.trx
  24. +2 −2 compiler/passes/surfaceAstDependencies.ml
  25. +2 −2 compiler/qmlcps/qmlCpsClientLib.js
  26. +4 −4 compiler/qmlpasses/pass_DbAccessorsGeneration.ml
  27. +103 −84 lib/stdlib/apis/apigenlib/apigenlib.opa
  28. +450 −445 lib/stdlib/apis/postgres/pg.opa
  29. +274 −252 lib/stdlib/apis/postgres/postgres.opa
  30. +18 −12 lib/stdlib/apis/postgres/types.opa
  31. +5 −1 lib/stdlib/core/pack/pack.opa
  32. +246 −0 lib/stdlib/database/postgres/db.opa
  33. +1 −0  lib/stdlib/new_syntax
View
2  Makefile
@@ -16,7 +16,7 @@ MAKE ?= $_
OCAMLBUILD_OPT ?= -j 6
ifndef NO_REBUILD_OPA_PACKAGES
-OPAOPT += --rebuild
+OPAOPT +=
endif
ifdef DEBUG_OCAMLBUILD
View
28 compiler/libqmlcompil/dbGen/dbGen_common.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of Opa.
@@ -16,6 +16,7 @@
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
module Arg = Base.Arg
+module Format = Base.Format
let version = 9 (* Should be the same as in db3/Dbgraph *)
type path = string list
@@ -59,7 +60,7 @@ type schema_node = {
plain : bool;
}
-type engine = [ `db3 | `mongo | `dropbox]
+type engine = [ `db3 | `mongo | `dropbox | `postgres ]
module Args = struct
@@ -74,16 +75,24 @@ module Args = struct
let descr = function
| `db3 -> "Db3"
| `mongo -> "Mongo"
+ | `postgres -> "Postgres"
| `dropbox -> "Dropbox"
- let assoc = [("mongo", `mongo); ("db3", `db3); ("dropbox", `dropbox)]
+ let assoc = [
+ ("mongo" ,`mongo);
+ ("db3" ,`db3);
+ ("dropbox" ,`dropbox);
+ ("postgres" ,`postgres);
+ ]
let r = ref None
let options = [
("--database", Arg.spec_fun_of_assoc
- (fun s -> r := Some {engine=s}) assoc,
- " Select kind of database (db3|mongo|dropbox)");
+ (fun s -> r := Some {engine=s}) assoc
+ , (Format.sprintf " Select kind of database [%a]"
+ (Format.pp_list "|" (Format.pp_fst Format.pp_print_string)) assoc)
+ );
]
let get_engine () = Option.map (fun r -> r.engine) !r
@@ -164,6 +173,7 @@ module Db = struct
| `db3 -> OptionalOpacapi.Types.Db3.t
| `mongo -> Opacapi.Types.DbMongo.t
| `dropbox -> Opacapi.Types.DbDropbox.t
+ | `postgres -> Opacapi.Types.DbPostgres.t
in
QmlAst.TypeName ([], typ ident)
@@ -172,7 +182,8 @@ module Db = struct
match engine with
| `db3 -> OptionalOpacapi.Types.db3set
| `mongo -> Opacapi.Types.DbMongoSet.t
- | `dropbox -> Opacapi.Types.dbdropboxset
+ | `dropbox -> Opacapi.Types.DbDropboxSet.t
+ | `postgres -> Opacapi.Types.DbPostgresSet.t
in
QmlAst.TypeName ([ty], typ ident)
@@ -182,12 +193,16 @@ module Db = struct
let dropbox_engine () =
QmlAst.TypeName ([], typ Opacapi.Types.DbDropbox.engine)
+ let postgres_engine () =
+ QmlAst.TypeName ([], typ Opacapi.Types.DbPostgres.engine)
+
let ref_path_ty tydata =
let tyengine =
match get_engine() with
| `db3 -> ref_path_ty tydata
| `dropbox -> dropbox_engine ()
| `mongo -> mongo_engine ()
+ | `postgres -> postgres_engine ()
in
QmlAst.TypeName ([tydata; tyengine],
(* typ don't use typ with type defined inside stdlib.core*)
@@ -199,6 +214,7 @@ module Db = struct
| `db3 -> val_path_ty tydata
| `dropbox -> dropbox_engine ()
| `mongo -> mongo_engine ()
+ | `postgres -> postgres_engine ()
in
QmlAst.TypeName ([tydata; tyengine],
(* typ don't use typ with type defined inside stdlib.core*)
View
4 compiler/libqmlcompil/dbGen/dbGen_private.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of Opa.
@@ -1939,7 +1939,7 @@ module CodeGenerator ( Arg : DbGenByPass.S ) = struct
"This kind of selection is not yet implemented by the db3 backend"
);
let dbinfo = StringListMap.find prefix dbinfo_map in
- let _, node, virtual_ = Schema_private.find_exprpath db_def.Schema_private.schema db_def.Schema_private.virtual_path ~kind path in
+ let _, node, virtual_ = Schema_private.find_exprpath gamma db_def.Schema_private.schema db_def.Schema_private.virtual_path ~kind path in
let r = match virtual_ with
| `virtualset (_, wty, false, _) ->
make_virtualset_fullpath ~context db_def.Schema_private.schema dbinfo gamma node path kind wty
View
158 compiler/libqmlcompil/dbGen/schema_private.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011, 2012, 2013 MLstate
This file is part of Opa.
@@ -891,44 +891,76 @@ let is_uniq t node query =
| _ -> false
in aux query keyty
+let fields_of_sqldata gamma schema node {Db. sql_fds=_; sql_tbs; sql_ops=_} =
+ List.fold_left
+ (fun acc tab ->
+ let node = SchemaGraphLib.find_field_edge schema node tab in
+ let ty = SchemaGraphLib.type_of_node (E.dst node) in
+ let ty =
+ QmlTypesUtils.Inspect.follow_alias_noopt_private gamma ty
+ ~until:Opacapi.Types.dbset in
+ match ty with
+ | Q.TypeName ([data; _], name) when Q.TypeIdent.to_string name = "dbset" ->
+ let rec aux = function
+ | Q.TypeRecord (Q.TyRow (rows, _)) -> rows @ acc
+ | ty -> aux (QmlTypesUtils.Inspect.follow_alias_noopt_private gamma ty)
+ in aux data
+ | _ -> raise Not_found
+ )
+ [] sql_tbs
-let coerce_query_element ~context gamma ty (query, options) =
- let coerce new_annots wrap ty expr =
- let e = QmlAstCons.UntypedExpr.coerce expr ty in
- Q.QAnnot.expr e::new_annots, wrap e
- in
- let a, options =
- let a = [] in
- let optmap f a o = match o with
+let type_of_sqldata gamma schema node ({Db. sql_fds; sql_tbs=_; sql_ops=_} as query) =
+ let fields = fields_of_sqldata gamma schema node query in
+ let fields = List.filter
+ (fun (f, _) -> List.exists (fun (_dname, f1) -> String.equal f f1) sql_fds)
+ fields
+ in Q.TypeRecord (Q.TyRow (fields, None))
+
+let simple_coerce new_annots wrap ty expr =
+ let e = QmlAstCons.UntypedExpr.coerce expr ty in
+ Q.QAnnot.expr e::new_annots, wrap e
+
+
+let coerce_query_options options =
+ let a = [] in
+ let optmap f a o = match o with
| None -> a, None
| Some o -> let x, y = f a o in x, Some y in
- let a, limit =
- optmap
- (fun a -> coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
- a options.Db.limit
- in let a, skip =
- optmap
- (fun a -> coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
- a options.Db.skip
- in let a, sort =
- let ty =
- Q.TypeSum (
- let void = Q.TypeRecord (QmlAstCons.Type.Row.make []) in
- QmlAstCons.Type.Col.make [
- [("down", void)];
- [("up", void)];
- ]
- )
- in
- optmap
- (fun a fields ->
- List.fold_left_map
- (fun a (flds, e) -> coerce a (fun e -> (flds, e)) ty e)
- a fields
- ) a options.Db.sort
+ let a, limit =
+ optmap
+ (fun a -> simple_coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
+ a options.Db.limit
+ in let a, skip =
+ optmap
+ (fun a -> simple_coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
+ a options.Db.skip
+ in let a, sort =
+ let ty =
+ Q.TypeSum (
+ let void = Q.TypeRecord (QmlAstCons.Type.Row.make []) in
+ QmlAstCons.Type.Col.make [
+ [("down", void)];
+ [("up", void)];
+ ]
+ )
in
- (a, {Db.limit; skip; sort})
+ optmap
+ (fun a fields ->
+ List.fold_left_map
+ (fun a (flds, e) -> simple_coerce a (fun e -> (flds, e)) ty e)
+ a fields
+ ) a options.Db.sort
+ in
+ (a, {Db.limit; skip; sort})
+
+let coerce_query_element ~qwrap ~quwrap ~context gamma ty (query, options) =
+ let coerce new_annots wrap ty expr =
+ try
+ let a, e = simple_coerce new_annots (fun e -> qwrap e) ty (quwrap expr) in
+ a, wrap e
+ with Not_found -> new_annots, wrap expr
in
+ let a, options = coerce_query_options options in
let rec aux new_annots ty query =
let coerce = coerce new_annots in
let aux2 wrap ty (q1, q2) =
@@ -1062,11 +1094,35 @@ let rec convert_dbpath ~context t gamma node kind select path0 path =
with Not_found ->
cerror "According the path definition, query is invalid"
in
- coerce_query_element ~context gamma ty (query, options)
+ let qwrap x = x in let quwrap x = x in
+ coerce_query_element ~qwrap ~quwrap ~context gamma ty (query, options)
in
let new_annots', epath = convert_dbpath ~context t gamma (SchemaGraph.unique_next t node) kind select path0 path in
new_annots @ new_annots', (Db.Query (query, options))::epath
+ | Db.SQLQuery ({Db. sql_fds; sql_tbs; sql_ops} as sqlquery, options)::path ->
+ assert (path = []); (*TODO ?*)
+ let fields = try
+ fields_of_sqldata gamma t node sqlquery
+ with Not_found ->
+ cerror "According the path definition, query is invalid"
+ in
+ let ty = Q.TypeRecord (Q.TyRow (fields, None)) in
+ let new_annots, (sql_ops, options) =
+ match sql_ops with
+ | None ->
+ let n, options = coerce_query_options options in
+ n, (sql_ops, options)
+ | Some q ->
+ let qwrap x = `expr x in
+ let quwrap = function | `expr e -> e | _ -> raise Not_found in
+ let a, (q, o) =
+ coerce_query_element ~qwrap ~quwrap ~context gamma ty (q, options)
+ in a, (Some q, o)
+ in
+ new_annots, (Db.SQLQuery ({Db.sql_tbs; sql_fds; sql_ops}, options))::[]
+
+
let get_virtual_path vpath epath =
let rec aux acc = function
| ((Db.Decl_fld f1)::q1, ((Db.FldKey f2) as e)::q2) when f1 = f2 ->
@@ -1087,7 +1143,7 @@ let get_virtual_path vpath epath =
(p, r, (ident, tyread, tywrite))::acc
) vpath []
-let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db.Option) ?epath0 vpath epath =
+let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db.Option) ?epath0 gamma vpath epath =
let context = match context with
| Some context -> QmlError.Context.merge2 context (V.label node).C.context
| None -> (V.label node).C.context
@@ -1104,7 +1160,7 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
let setty = node.C.ty in
let dataty, dnode, _ =
find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node)
- ~kind ~epath0 vpath epath
+ ~kind ~epath0 gamma vpath epath
in
(match setty with
| Q.TypeName ([setparam; _], name) when Q.TypeIdent.to_string name = "dbset" ->
@@ -1139,7 +1195,7 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
in
match epath, (V.label node).C.nlabel with
| path, C.Hidden ->
- find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node) ~kind ~epath0 vpath path
+ find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node) ~kind ~epath0 gamma vpath path
| [], C.Multi -> (
match node.C.ty with
| Q.TypeName ([setparam;_], name) when Q.TypeIdent.to_string name = "dbset" ->
@@ -1157,32 +1213,43 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
fld
QmlPrint.pp#path_elts epath0
in
- find_exprpath_aux ~context t ~node:next ~kind ~epath0 vpath epath
+ find_exprpath_aux ~context t ~node:next ~kind ~epath0 gamma vpath epath
| (Db.Query (query, _))::epath, C.Multi ->
let partial = not (is_uniq t node query) in
aux_multi epath partial
+ | (Db.SQLQuery ({Db. sql_fds; sql_tbs=_; sql_ops=_} as sqlquery, _))::epath, _ ->
+ assert (epath = []); (*TODO ?*)
+ let fields = fields_of_sqldata gamma t node sqlquery in
+ let fields = List.filter
+ (fun (f, _) -> List.exists (fun (_dname, f1) -> String.equal f f1) sql_fds)
+ fields
+ in
+ let partial = true in
+ let rebuildt = (fun t -> if partial then C.Db.set t else t) in
+ let dataty = Q.TypeRecord (Q.TyRow (fields, None)) in
+ rebuildt dataty, node, `virtualset (dataty, dataty, partial, rebuildt)
| (Db.ExprKey _)::epath, C.Multi ->
aux_multi epath false
| (Db.FldKey fld)::_rp, C.Sum ->
let e = SchemaGraphLib.find_field_edge t node fld in
- find_exprpath_aux ~context t ~node:(E.dst e) ~kind ~epath0 vpath epath
+ find_exprpath_aux ~context t ~node:(E.dst e) ~kind ~epath0 gamma vpath epath
| Db.NewKey::epath, C.Multi when SchemaGraphLib.multi_key t node = C.Kint ->
- find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node) ~kind ~epath0 vpath epath
+ find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node) ~kind ~epath0 gamma vpath epath
| k::_,_ ->
internal_error
"Failed to lookup path %a at \"%a\""
QmlPrint.pp#path_elts epath0
QmlPrint.pp#path_elt k
-let find_exprpath ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db.Option) vpath epath =
+let find_exprpath ?context gamma t ?(node=SchemaGraphLib.get_root t) ?(kind=Db.Option) vpath epath =
let context = match context with
| Some context -> QmlError.Context.merge2 context (V.label node).C.context
| None -> (V.label node).C.context
in
match get_virtual_path vpath epath with
- | [] -> find_exprpath_aux ~context t ~node ~kind vpath epath
+ | [] -> find_exprpath_aux ~context t ~node ~kind gamma vpath epath
| [(_p, [], (ident, tyread, tywrite))] ->
- (match find_exprpath_aux ~context t ~node ~kind vpath epath with
+ (match find_exprpath_aux ~context t ~node ~kind gamma vpath epath with
| ty, n, `realpath -> ty, n, `virtualpath (ident, tyread, tywrite)
| _, _, `virtualset _ -> QmlError.error context
"Can't make a virtual path on a dbset"
@@ -1323,7 +1390,7 @@ let preprocess_path ~context t gamma prepath kind select =
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 select prepath prepath in
- let ty, _node, virtual_ = find_exprpath ~context db_def.schema db_def.virtual_path ~node:root ~kind epath in
+ let ty, _node, virtual_ = find_exprpath ~context gamma db_def.schema db_def.virtual_path ~node:root ~kind epath in
let label = Annot.nolabel "dbgen.preprocess_path" in
let kind = Preprocess.kind ~context gamma kind ty virtual_ in
let (ty, virtual_), select = Preprocess.select ~context gamma select ty virtual_ in
@@ -1670,3 +1737,4 @@ let foldmap_expr f acc t =
acc, { db_def with schema = s }
in
StringListMap.fold_map f t acc
+
View
110 compiler/libqmlcompil/qmlAst.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of Opa.
@@ -23,7 +23,7 @@
2009, Louis Gesbert <Louis.Gesbert@mlstate.com>
2009, Mehdi Bouaziz <Mehdi.Bouaziz@mlstate.com>
2009, David Rajchenbach-Teller <David.Teller@mlstate.com>
- 2010, 2012 Quentin Bourgerie
+ 2010, 2013 Quentin Bourgerie
*)
(**
@@ -145,7 +145,7 @@ struct
| SFlds of ('expr, 'expr select) fields
| SId of 'expr * 'expr select
- type 'expr query =
+ type ('epath, 'expr) query =
| QEq of 'expr
| QGt of 'expr
| QLt of 'expr
@@ -154,12 +154,18 @@ struct
| QNe of 'expr
| QMod of int
| QIn of 'expr
- | QOr of 'expr query * 'expr query
- | QAnd of 'expr query * 'expr query
- | QNot of 'expr query
- | QFlds of ('expr, 'expr query) fields
+ | QOr of ('epath, 'expr) query * ('epath, 'expr) query
+ | QAnd of ('epath, 'expr) query * ('epath, 'expr) query
+ | QNot of ('epath, 'expr) query
+ | QFlds of ('epath, ('epath, 'expr) query) fields
| QExists of bool
+ type 'expr sqlquery = {
+ sql_fds : (string * string) list;
+ sql_tbs : string list;
+ sql_ops : ('expr, [`expr of 'expr | `bind of string]) query option;
+ }
+
type 'expr query_options = {
limit : 'expr option;
skip : 'expr option;
@@ -220,7 +226,8 @@ struct
| FldKey of string
| ExprKey of 'expr
| NewKey
- | Query of 'expr query * 'expr query_options
+ | Query of ('expr, 'expr) query * 'expr query_options
+ | SQLQuery of 'expr sqlquery * 'expr query_options
type 'expr path = 'expr path_elt list
@@ -229,9 +236,10 @@ struct
path, absolute or relative, ending with the filename prefix). DbGen sets
this to [~/.mlstate/<progname>/default] by default (based on argv.(0)) *)
type engine = [
- |`db3
- |`mongo
- |`dropbox
+ | `db3
+ | `mongo
+ | `dropbox
+ | `postgres
]
type options = {
@@ -275,12 +283,12 @@ struct
let pp = BaseFormat.fprintf
- let rec pp_field pp_expr fmt =
+ let rec pp_field pp_epath fmt =
function
- | `string t0::((_::_) as q) -> pp fmt "%s.%a" t0 (pp_field pp_expr) q
- | `expr t0::q -> pp fmt "[%a]%a" pp_expr t0 (pp_field pp_expr) q
+ | `string t0::((_::_) as q) -> pp fmt "%s.%a" t0 (pp_field pp_epath) q
+ | `expr t0::q -> pp fmt "[%a]%a" pp_epath t0 (pp_field pp_epath) q
| `string t0::[] -> pp fmt "%s" t0
- | `any::q -> pp fmt "[_]%a" (pp_field pp_expr) q
+ | `any::q -> pp fmt "[_]%a" (pp_field pp_epath) q
| [] -> pp fmt ""
let rec pp_update pp_expr fmt = function
@@ -317,8 +325,7 @@ struct
pp fmt "%a}" (pp_update_options pp_expr) o
)
-
- let rec pp_query pp_expr fmt = function
+ let rec pp_query pp_epath pp_expr fmt = function
| QEq expr -> pp fmt "== %a" pp_expr expr
| QGt expr -> pp fmt "> %a" pp_expr expr
| QLt expr -> pp fmt "< %a" pp_expr expr
@@ -327,13 +334,20 @@ struct
| QNe expr -> pp fmt "!= %a" pp_expr expr
| QMod i -> pp fmt "mod %d" i
| QIn expr -> pp fmt "in %a" pp_expr expr
- | QOr (q1, q2) -> pp fmt "(%a) or (%a)" (pp_query pp_expr) q1 (pp_query pp_expr) q2
- | QAnd (q1, q2) -> pp fmt "(%a) and (%a)" (pp_query pp_expr) q1 (pp_query pp_expr) q2
- | QNot query -> pp fmt "not (%a)" (pp_query pp_expr) query
+ | QOr (q1, q2) ->
+ pp fmt "(%a) or (%a)"
+ (pp_query pp_epath pp_expr) q1
+ (pp_query pp_epath pp_expr) q2
+ | QAnd (q1, q2) ->
+ pp fmt "(%a) and (%a)"
+ (pp_query pp_epath pp_expr) q1
+ (pp_query pp_epath pp_expr) q2
+ | QNot query ->
+ pp fmt "not (%a)" (pp_query pp_epath pp_expr) query
| QFlds fields ->
List.iter
(function (f, q) ->
- pp fmt "%a %a" (pp_field pp_expr) f (pp_query pp_expr) q) fields
+ pp fmt "%a %a" (pp_field pp_epath) f (pp_query pp_epath pp_expr) q) fields
| QExists _ -> pp fmt "exists"
let rec pp_select pp_expr fmt = function
@@ -362,12 +376,38 @@ struct
fields)
options.sort
+ let pp_sqlquery pp_expr fmt {sql_fds; sql_tbs; sql_ops} =
+ pp fmt "SELECT ";
+ (match sql_fds with
+ | [] -> pp fmt "* "
+ | _ ->
+ (BaseFormat.pp_list ","
+ (fun fmt (db, field) ->
+ (match db with "" -> ()
+ | _ -> pp fmt "%s." db);
+ pp fmt "%s" field
+ ))
+ fmt sql_fds
+ );
+ pp fmt " FROM ";
+ (BaseFormat.pp_list "," Format.pp_print_string) fmt sql_tbs;
+ match sql_ops with
+ | None -> ()
+ | Some sql_ops ->
+ pp fmt " WHERE ";
+ let pp_qexpr fmt = function
+ | `expr e -> pp fmt "%a" pp_expr e
+ | `bind s -> Format.pp_print_string fmt s
+ in
+ (pp_query pp_expr pp_qexpr) fmt sql_ops
+
let pp_path_elt pp_expr f =
function
| FldKey (s) -> pp f "/%s" s
| ExprKey e -> pp f "[@[<hv>%a@]]" pp_expr e
| NewKey -> pp f "[?]"
- | Query (q, o) -> pp f "[%a%a]" (pp_query pp_expr) q (pp_options pp_expr) o
+ | Query (q, o) -> pp f "[%a%a]" (pp_query pp_expr pp_expr) q (pp_options pp_expr) o
+ | SQLQuery (q, o) -> pp f "[%a%a]" (pp_sqlquery pp_expr) q (pp_options pp_expr) o
let pp_path_elts pp_expr fmt elts =
pp fmt "%a" (BaseFormat.pp_list "" (pp_path_elt pp_expr)) elts
@@ -401,6 +441,7 @@ struct
| `db3 -> "@db3"
| `mongo -> "@mongo"
| `dropbox -> "@dropbox"
+ | `postgres -> "@postgres"
let path_decl_key_to_string = function
| Decl_fld s -> "/"^s
@@ -530,7 +571,7 @@ struct
(sub_db_update_options sub_e sub_ty)
(update, options))
- let rec sub_db_query sub_e sub_ty = function
+ let rec sub_db_query sub_ep sub_e sub_ty = function
| QExists _
| QMod _ as e -> TU.sub_ignore e
| QEq e -> TU.wrap (fun e -> QEq e) (sub_e e)
@@ -543,17 +584,17 @@ struct
| QOr (q1, q2) ->
TU.wrap
(fun (q1,q2) -> QOr (q1,q2))
- (TU.sub_2 (sub_db_query sub_e sub_ty) (sub_db_query sub_e sub_ty) (q1, q2))
+ (TU.sub_2 (sub_db_query sub_ep sub_e sub_ty) (sub_db_query sub_ep sub_e sub_ty) (q1, q2))
| QAnd (q1, q2) ->
TU.wrap
(fun (q1,q2) -> QAnd (q1,q2))
- (TU.sub_2 (sub_db_query sub_e sub_ty) (sub_db_query sub_e sub_ty) (q1, q2))
- | QNot q -> TU.wrap (fun e -> QNot e) (sub_db_query sub_e sub_ty q)
+ (TU.sub_2 (sub_db_query sub_ep sub_e sub_ty) (sub_db_query sub_ep sub_e sub_ty) (q1, q2))
+ | QNot q -> TU.wrap (fun e -> QNot e) (sub_db_query sub_ep sub_e sub_ty q)
| QFlds flds ->
TU.wrap
(fun fields -> QFlds fields)
- (sub_db_fields sub_e (sub_db_query sub_e sub_ty) flds)
+ (sub_db_fields sub_ep (sub_db_query sub_ep sub_e sub_ty) flds)
let sub_db_query_options sub_e _sub_ty opt =
TU.wrap
@@ -572,9 +613,22 @@ struct
| Query (q, o) ->
TU.wrap
(fun (q, o) -> Query (q, o))
- (TU.sub_2 (sub_db_query sub_e sub_ty) (sub_db_query_options sub_e sub_ty)
+ (TU.sub_2 (sub_db_query sub_e sub_e sub_ty) (sub_db_query_options sub_e sub_ty)
(q, o)
)
+ | SQLQuery ({sql_fds; sql_tbs; sql_ops}, o) ->
+ let sub_eq = function
+ | `bind _ as x -> TU.sub_ignore x
+ | `expr e ->
+ TU.wrap (fun e -> `expr e) (sub_e e)
+ in
+ TU.wrap
+ (fun (sql_ops, o) -> SQLQuery ({sql_fds; sql_tbs; sql_ops}, o))
+ (TU.sub_2
+ (TU.sub_option (sub_db_query sub_e sub_eq sub_ty))
+ (sub_db_query_options sub_e sub_ty)
+ (sql_ops, o)
+ )
let foldmap_expr f acc dbdef =
let cons, subs = sub_db_def TU.sub_current TU.sub_ignore dbdef in
View
106 compiler/libqmlcompil/qmlAstWalk.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of Opa.
@@ -788,3 +788,107 @@ struct
let code_size code = CodeExpr.fold (fun acc e -> Expr.fold (fun acc _ -> acc + 1) acc e) 0 code
end
+
+module DbWalk =
+struct
+ module Query = Traverse.Make2
+ (struct
+ type 'a t = ('b, 'c) QmlAst.Db.query constraint 'a = ('b * 'c * _)
+
+ let foldmap tra acc input =
+ let binop build q0 q1 =
+ let acc, q0' = tra acc q0 in
+ let acc, q1' = tra acc q1 in
+ acc, if q0 == q0' && q1 == q1' then input else build q0' q1'
+ in
+ match input with
+ | Db.QMod _
+ | Db.QExists _
+ | Db.QEq _
+ | Db.QGt _
+ | Db.QLt _
+ | Db.QGte _
+ | Db.QLte _
+ | Db.QNe _
+ | Db.QIn _ -> acc, input
+ | Db.QOr (q0, q1) -> binop (fun q0 q1 -> Db.QOr (q0, q1)) q0 q1
+ | Db.QAnd (q0, q1) -> binop (fun q0 q1 -> Db.QAnd (q0, q1)) q0 q1
+ | Db.QNot q ->
+ let acc, q' = tra acc q in
+ acc, if q == q' then input else Db.QNot q'
+ | Db.QFlds flds ->
+ let acc, flds' =
+ List.fold_left_map_stable
+ (fun acc ((s,f) as bnd) ->
+ let acc, f' = tra acc f in
+ acc, if f == f' then bnd else (s, f')
+ ) acc flds in
+ acc, if flds == flds' then input else Db.QFlds flds'
+
+ let fold tra acc input =
+ let binop q0 q1 = tra (tra acc q0) q1 in
+ match input with
+ | Db.QMod _
+ | Db.QExists _
+ | Db.QEq _
+ | Db.QGt _
+ | Db.QLt _
+ | Db.QGte _
+ | Db.QLte _
+ | Db.QNe _
+ | Db.QIn _ -> acc
+ | Db.QOr (q0, q1) -> binop q0 q1
+ | Db.QAnd (q0, q1) -> binop q0 q1
+ | Db.QNot q -> tra acc q
+ | Db.QFlds flds ->
+ List.fold_left (fun acc (_,f) -> tra acc f) acc flds
+
+ let iter tra input = Traverse.Unoptimized.iter foldmap tra input
+ let map tra input = Traverse.Unoptimized.map foldmap tra input
+ end)
+
+ module Update = Traverse.Make2
+ (struct
+ type 'a t = 'b QmlAst.Db.update constraint 'a = ('b * _ * _)
+
+ let foldmap tra acc input =
+ match input with (* Simple updating*)
+ | Db.UExpr _
+ | Db.UIncr _
+ | Db.UAppend _
+ | Db.UAppendAll _
+ | Db.URemove _
+ | Db.URemoveAll _
+ | Db.UPop
+ | Db.UShift -> acc, input
+ | Db.UId (e, u) ->
+ let acc, u' = tra acc u in
+ acc, if u == u' then input else Db.UId (e, u')
+ | Db.UFlds flds ->
+ let acc, flds' =
+ List.fold_left_map_stable
+ (fun acc ((s,f) as bnd) ->
+ let acc, f' = tra acc f in
+ acc, if f == f' then bnd else (s, f')
+ ) acc flds in
+ acc, if flds == flds' then input else Db.UFlds flds'
+
+ let fold tra acc input =
+ match input with
+ | Db.UExpr _
+ | Db.UIncr _
+ | Db.UAppend _
+ | Db.UAppendAll _
+ | Db.URemove _
+ | Db.URemoveAll _
+ | Db.UPop
+ | Db.UShift -> acc
+ | Db.UId (_, u) -> tra acc u
+ | Db.UFlds flds ->
+ List.fold_left (fun acc (_,f) -> tra acc f) acc flds
+
+ let iter tra input = Traverse.Unoptimized.iter foldmap tra input
+ let map tra input = Traverse.Unoptimized.map foldmap tra input
+ end)
+
+end
View
14 compiler/libqmlcompil/qmlAstWalk.mli
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of Opa.
@@ -160,3 +160,15 @@ sig
(** shows the number of nodes in the expressions of a code *)
val code_size : QmlAst.code -> int
end
+
+module DbWalk : sig
+ module Query :
+ TraverseInterface.TRAVERSE
+ with type 'a t = ('b, 'c) QmlAst.Db.query constraint 'a = 'b * 'c * _
+ and type 'a container = ('b, 'c) QmlAst.Db.query constraint 'a = 'b * 'c * _
+
+ module Update :
+ TraverseInterface.TRAVERSE
+ with type 'a t = 'b QmlAst.Db.update constraint 'a = 'b * _ * _
+ and type 'a container = 'b QmlAst.Db.update constraint 'a = 'b * _ * _
+end
View
41 compiler/libqmlcompil/qmlDbGen.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011, 2012, 2013 MLstate
This file is part of Opa.
@@ -32,7 +32,7 @@ module DbAst = QmlAst.Db
module C = DbGen_common
-type engine = [`db3 | `mongo | `dropbox]
+type engine = DbAst.engine
let settyp = DbGen_common.settyp
@@ -53,7 +53,9 @@ module Schema = struct
package : ObjectFiles.package_name;
}
- type query = QmlAst.expr DbAst.query * QmlAst.expr DbAst.query_options
+ type query = (QmlAst.expr, QmlAst.expr) DbAst.query * QmlAst.expr DbAst.query_options
+
+ type sqlquery = QmlAst.expr DbAst.sqlquery * QmlAst.expr DbAst.query_options
type set_kind =
| Map of QmlAst.ty * QmlAst.ty
@@ -64,6 +66,7 @@ module Schema = struct
| Plain
| Partial of bool (* Inside sum*) * string list * string list
| SetAccess of set_kind * string list * (bool (*is_unique*) * query) option * QmlAst.path option
+ | SqlAccess of sqlquery
type node = {
ty : QmlAst.ty;
@@ -76,7 +79,7 @@ module Schema = struct
| None -> ()
| Some (u, (q, o)) ->
Format.fprintf fmt "[%a%a]/* uniq : %b */"
- (QmlAst.Db.pp_query QmlPrint.pp#expr) q
+ (QmlAst.Db.pp_query QmlPrint.pp#expr QmlPrint.pp#expr) q
(QmlAst.Db.pp_options QmlPrint.pp#expr) o
u
@@ -101,6 +104,10 @@ module Schema = struct
pp_set_kind sk
pp_query query
(Option.pp (DbAst.pp_path_elts QmlPrint.pp#expr)) epath
+ | SqlAccess (sqlquery, option) ->
+ Format.fprintf fmt "@[<hov>sql access : [%a%a]@]"
+ (QmlAst.Db.pp_sqlquery QmlPrint.pp#expr) sqlquery
+ (QmlAst.Db.pp_options QmlPrint.pp#expr) option
let pp_node fmt node =
Format.fprintf fmt "{@[<hov>type : %a; @. kind : %a; ...@]}"
@@ -196,6 +203,7 @@ module Schema = struct
| (DbAst.FldKey _s0, _) -> false
| (DbAst.ExprKey _, C.Multi_edge _) -> true
| (DbAst.Query _, C.Multi_edge _) -> true
+ | (DbAst.SQLQuery _, C.Multi_edge _) -> true
| (DbAst.NewKey, _) -> true
| _ -> assert false (* TODO *)
in
@@ -232,7 +240,7 @@ module Schema = struct
| C.Sum -> true
| _ -> false
- let get_node (schema:t) path =
+ let get_node gamma (schema:t) path =
#<If>
Format.eprintf "Get node : @[with path %a@]@\n" QmlPrint.pp#path_elts path;
#<End>;
@@ -249,7 +257,6 @@ module Schema = struct
let database = get_database schema dbname in
let llschema = declaration.Sch.schema in
let find_next_step (node, kind, path) fragment =
- let next = next llschema node fragment in
let get_setkind schema node =
match Graph.succ_e schema node with
| [edge] ->
@@ -274,12 +281,14 @@ module Schema = struct
in
match fragment with
| DbAst.ExprKey expr ->
+ let next = next llschema node fragment in
let setkind = get_setkind llschema node in
let options = {DbAst.limit = None; skip = None; sort = None} in
let kind = SetAccess (setkind, path, Some (true, (DbAst.QEq expr, options)), None) in
(next, kind, path)
| DbAst.FldKey key ->
+ let next = next llschema node fragment in
let kind =
let nlabel = Graph.V.label next in
match nlabel.C.nlabel with
@@ -291,10 +300,12 @@ module Schema = struct
| Partial (sum, path, part), _ ->
Partial (sum && is_sum node, path, key::part)
| Plain, _ -> Partial (is_sum node, path, key::[])
+ | SqlAccess _, _
| SetAccess _, _ -> raise (Base.NotImplemented "Selection inside a multi node")
in let path = key::path
in (next, kind, path)
| DbAst.Query (query, options) ->
+ let next = next llschema node fragment in
begin match kind with
| SetAccess (_k, path, None, _) ->
let uniq = Sch.is_uniq llschema node query in
@@ -306,13 +317,28 @@ module Schema = struct
| _ ->
raise (Base.NotImplemented "Query in a non multi node")
end
+ | DbAst.SQLQuery (query, options) ->
+ begin match kind with
+ | SqlAccess _
+ | SetAccess (_, _, Some _, _) ->
+ raise (Base.NotImplemented "Selection inside a multi node")
+ | Partial _ ->
+ raise (Base.NotImplemented "SQL query on a partial node")
+ | SetAccess (_, _, None, _) | Compose _ | Plain ->
+ let ty = Sch.type_of_sqldata gamma llschema node query in
+ ({node with C.ty}, SqlAccess (query, options), path)
+ end
| DbAst.NewKey -> raise (Base.NotImplemented "New key")
in
let node, kind =
let rec find path ((node, kind, _) as x) =
match (path, kind) with
| [], _ -> node, kind
- | _::_, SetAccess (k, p, (Some _ as q), None) -> node, SetAccess(k, p, q, Some path)
+ | _::_, SetAccess (k, p, (Some _ as q), None) ->
+ node, SetAccess(k, p, q, Some path)
+ | _::_, SqlAccess q ->
+ assert (path = []);
+ node, SqlAccess q
| t::q, _ -> find q (find_next_step x t)
in find path (get_root llschema, Compose [], [])
in
@@ -337,6 +363,7 @@ module Schema = struct
Partial (sum, List.rev path, List.rev part)
| SetAccess (k, path, query, epath) ->
SetAccess (k, List.rev path, query, epath)
+ | SqlAccess _ as sa -> sa
| Plain -> Plain
in
let default =
View
11 compiler/libqmlcompil/qmlDbGen.mli
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011, 2012, 2013 MLstate
This file is part of Opa.
@@ -19,7 +19,7 @@
(** {6 Command line arguments } *)
(** Describes different backend that dbgen handle. *)
-type engine = [`db3 | `mongo | `dropbox]
+type engine = QmlAst.Db.engine
(** Command line specification provides necessary options for switch
database backend. *)
@@ -58,7 +58,9 @@ module Schema: sig
package : ObjectFiles.package_name;
}
- type query = QmlAst.expr QmlAst.Db.query * QmlAst.expr QmlAst.Db.query_options
+ type query = (QmlAst.expr, QmlAst.expr) QmlAst.Db.query * QmlAst.expr QmlAst.Db.query_options
+
+ type sqlquery = QmlAst.expr QmlAst.Db.sqlquery * QmlAst.expr QmlAst.Db.query_options
type set_kind =
| Map of QmlAst.ty * QmlAst.ty
@@ -69,6 +71,7 @@ module Schema: sig
| Plain
| Partial of bool * string list * string list
| SetAccess of set_kind * string list * (bool * query) option (*bool == unique*) * QmlAst.path option
+ | SqlAccess of sqlquery
type node = {
ty : QmlAst.ty;
@@ -185,7 +188,7 @@ module Schema: sig
val get_db_declaration: t -> database list
- val get_node: t -> QmlAst.path -> node
+ val get_node: QmlTypes.gamma -> t -> QmlAst.path -> node
val pp_node: node BaseFormat.pprinter
View
3  compiler/libqmlcompil/qmlDependencies.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011, 2012, 2013 MLstate
This file is part of Opa.
@@ -264,6 +264,7 @@ let get_expr_dep_context ?filter e =
| Q.Db.FldKey s -> Option.if_none filter (add_root s acc) acc
| Q.Db.NewKey
| Q.Db.ExprKey _
+ | Q.Db.SQLQuery _
| Q.Db.Query _ ->
(* not possible, see the parser *)
assert false
View
1  compiler/libtrx/pgrammar.ml
@@ -142,6 +142,7 @@ let rewrite_funs pg =
else
failwith (Printf.sprintf "function %s is undefined" f)
| Some (fdef, _) ->
+ Format.eprintf "%s \n%!" f;
let functions = StringMap.remove f functions in
let expected_arity = List.length fdef.P.vars in
if expected_arity = List.length vars then
View
1  compiler/opa/_tags
@@ -17,6 +17,7 @@
<opa_InsertRemote.{ml,mli}>: use_libqmlcompil, use_opalib, use_qmlpasses, use_jslang
<pass_MongoAccessGeneration.{ml,mli}>: use_libqmlcompil, use_opalang, use_qmlpasses
<pass_DropBoxCodeGeneration.{ml,mli}>: use_libqmlcompil, use_opalang, use_qmlpasses
+<pass_PostgresCodeGeneration.{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
5 compiler/opa/compiler.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of Opa.
@@ -209,6 +209,9 @@ let compile backend_handlers =
|?> (If.database `dropbox,
"DropBoxCodeGeneration", S3.pass_DropBoxCodeGeneration)
+ |?> (If.database `postgres,
+ "PostgresCodeGeneration", S3.pass_PostgresCodeGeneration)
+
(* could be just after typing, if dbgen didn't complain that it can't find its coercions :/ *)
|+> ("PurgeTypeDirectivesAfterTyping", S3.pass_PurgeTypeDirectiveAfterTyping)
View
4 compiler/opa/pass_DbEngineImportation.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of Opa.
@@ -38,6 +38,7 @@ struct
|`db3 -> "db3"
|`mongo -> "mongo"
|`dropbox -> "dropbox"
+ |`postgres -> "postgres"
in
List.iter (fun x -> Format.fprintf f "%s;" (aux x)) l
end
@@ -58,6 +59,7 @@ let import_packages engines =
| `db3 -> "stdlib.database.db3"
| `mongo -> "stdlib.database.mongo"
| `dropbox -> "stdlib.database.dropbox"
+ | `postgres -> "stdlib.database.postgres"
)
engines
in
View
12 compiler/opa/pass_DropBoxCodeGeneration.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of OPA.
@@ -131,9 +131,9 @@ module Generator = struct
OManager.error "This kind of update is not yet implemented by dropbox backend : %a"
(QmlAst.Db.pp_update QmlPrint.pp#expr) u
- let get_node ~context schema path =
+ let get_node ~context gamma schema path =
try
- DbSchema.get_node schema path
+ DbSchema.get_node gamma schema path
with Base.NotImplemented s ->
QmlError.error context
"Can't generates mongo access because : %s is not yet implemented"
@@ -194,7 +194,7 @@ module Generator = struct
let annotmap, path =
let rpath = List.map (fun s -> `string s ) rpath in
expr_of_path gamma annotmap (`string dbname::rpath) in
- let partial = List.map (fun s -> `string s) partial in
+ let partial = List.map (fun s -> `string s) partial in
let annotmap, uexpr =
update_to_expr gamma annotmap dataty (DbAst.UFlds [partial, u])
in
@@ -280,7 +280,7 @@ module Generator = struct
and string_path ~context gamma annotmap schema (kind, strpath) select =
let node =
let strpath = List.map (fun k -> DbAst.FldKey k) strpath in
- get_node ~context schema strpath in
+ get_node ~context gamma schema strpath in
let strpath = List.map (fun s -> `string s) strpath in
gen_string_path ~context expr_of_strexprpath gamma annotmap schema node (kind, strpath) select
@@ -312,7 +312,7 @@ module Generator = struct
let path ~context gamma annotmap schema (label, dbpath, kind, select) =
- let node = get_node ~context schema dbpath in
+ let node = get_node ~context gamma schema dbpath in
match node.DbSchema.database.DbSchema.options.DbAst.backend with
| `dropbox -> (
let annotmap, mongopath =
View
16 compiler/opa/pass_MongoAccessGeneration.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011, 2012 MLstate
+ Copyright © 2011-2013 MLstate
This file is part of Opa.
@@ -19,7 +19,7 @@
(**
Pass for MongoDB backend
-
+
@author Quentin Bourgerie
*)
@@ -136,6 +136,7 @@ module Generator = struct
let strlst_to_field fld =
BaseFormat.sprintf "%a" (BaseFormat.pp_list "." Format.pp_print_string) fld
+
let expr_of_strexprpath_rev ?any gamma annotmap path =
let path = match path with [] -> [`string "value"] | _ -> path in
let fld_to_string annotmap fld =
@@ -477,9 +478,9 @@ module Generator = struct
| DbAst.SStar -> Some DbAst.SStar
| _ -> None
- let get_node ~context schema path =
+ let get_node ~context gamma schema path =
try
- DbSchema.get_node schema path
+ DbSchema.get_node gamma schema path
with Base.NotImplemented s ->
QmlError.error context
"Can't generates mongo access because : %s is not yet implemented"
@@ -618,7 +619,7 @@ module Generator = struct
and string_path ~context gamma annotmap schema (kind, strpath) select =
let node =
let strpath = List.map (fun k -> DbAst.FldKey k) strpath in
- get_node ~context schema strpath in
+ get_node ~context gamma schema strpath in
match node.DbSchema.kind with
| DbSchema.SetAccess (setkind, path, query, _todo) ->
dbset_path ~context gamma annotmap (kind, path) setkind node query None select
@@ -837,6 +838,7 @@ module Generator = struct
),
`expr uexpr::embed_field
| DbAst.NewKey
+ | DbAst.SQLQuery _
| DbAst.Query _ ->
QmlError.error context
"This kind of sub selection is not yet implemented by mongo generator")
@@ -1082,7 +1084,7 @@ module Generator = struct
let path ~context gamma annotmap schema (label, dbpath, kind, select) =
- let node = get_node ~context schema dbpath in
+ let node = get_node ~context gamma schema dbpath in
match node.DbSchema.database.DbSchema.options.DbAst.backend with
| `mongo -> (
let annotmap, mongopath =
@@ -1168,7 +1170,7 @@ let clean_code gamma annotmap schema code =
| DbAst.Decl_fld k::_ -> [DbAst.FldKey k]
| _ -> assert false
in
- let fake_node = DbSchema.get_node schema fake_path in
+ let fake_node = DbSchema.get_node gamma schema fake_path in
if fake_node.DbSchema.database.DbSchema.options.DbAst.backend = `mongo then
begin match decl with
| DbAst.Db_TypeDecl ((DbAst.Decl_fld _)::p, ty) ->
View
671 compiler/opa/pass_PostgresCodeGeneration.ml
@@ -0,0 +1,671 @@
+(*
+ Copyright © 2011-2013 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/>.
+*)
+
+module Format = BaseFormat
+module List = BaseList
+
+module Q = QmlAst
+module QD = Q.Db
+module S = QmlDbGen.Schema
+
+module C = QmlAstCons.TypedExpr
+
+module Api =
+struct
+
+ module Db = Opacapi.DbPostgres
+
+end
+
+let label = Annot.nolabel "PostgresCodeGeneration"
+
+module QueryMap = BaseMap.Make(
+ struct
+ type t = S.sqlquery
+ let compare = Pervasives.compare
+ end
+)
+
+module UpdateMap = BaseMap.Make(
+ struct
+ type t = (S.query option * Q.expr QD.update)
+ let compare = Pervasives.compare
+ end
+)
+
+type env = {
+ ty_init : [ `foreign of string | `type_ of (string * string) ] StringListMap.t;
+ (* List of queries which create table *)
+ tb_init : string list;
+ (* (id of prepared statement, string query) *)
+ q_prepared : (string * string) QueryMap.t;
+ (* (id of prepared statement, string query) *)
+ u_prepared : (string * string) UpdateMap.t;
+ gamma : QmlTypes.gamma;
+ annotmap : Q.annotmap;
+ schema : S.t
+}
+
+module Generator =
+struct
+
+ let make_env gamma annotmap schema = {
+ tb_init = ["CREATE LANGUAGE plpgsql"];
+ ty_init = StringListMap.empty;
+ q_prepared = QueryMap.empty;
+ u_prepared = UpdateMap.empty;
+ gamma; annotmap; schema;
+ }
+
+ let get_node ~context gamma schema path =
+ try
+ S.get_node gamma schema path
+ with Base.NotImplemented s ->
+ QmlError.error context
+ "Can't generates postgres access because : %s is not yet implemented"
+ s
+
+ let pp_postgres_field =
+ Format.pp_list "."
+ (fun fmt -> function | `string s -> Format.pp_print_string fmt s | _ -> assert false)
+
+ let pp_table_name = (Format.pp_list "_" Format.pp_print_string)
+
+ let opa_to_data gamma annotmap expr =
+ let ty = QmlAnnotMap.find_ty (Annot.annot (Q.Label.expr expr)) annotmap in
+ match QmlTypesUtils.Inspect.follow_alias_noopt_private gamma ty with
+ | Q.TypeConst c ->
+ let fld = match c with
+ | Q.TyNull -> assert false
+ | Q.TyFloat -> "Float"
+ | Q.TyInt -> "Int"
+ | Q.TyString -> "String"
+ in
+ C.record annotmap [fld, expr]
+ | ty -> OManager.i_error
+ "expression of type @{<bright>%a@} in sql query are not yet implemented or unexpected"
+ QmlPrint.pp#ty ty
+
+ let database
+ ({gamma; annotmap; tb_init; q_prepared; u_prepared; _} as env)
+ name =
+ let annotmap, open_ = OpaMapToIdent.typed_val ~label Api.Db.open_ annotmap gamma in
+ let annotmap, name = C.string annotmap name in
+ let annotmap, tables =
+ let annotmap, tables =
+ List.fold_left
+ (fun (annotmap, tables) table ->
+ let annotmap, table = C.string annotmap table in
+ annotmap, table::tables
+ ) (annotmap, []) tb_init
+ in
+ C.list (annotmap, gamma) tables
+ in
+ let annotmap, statements =
+ let annotmap, statements =
+ QueryMap.fold
+ (fun _prepared (qid, query) (annotmap, statements) ->
+ let annotmap, qid = C.string annotmap qid in
+ let annotmap, query = C.string annotmap query in
+ (* TODO: Optimized types *)
+ let annotmap, types = C.list (annotmap, gamma) [] in
+ let annotmap, statement =
+ C.record annotmap [
+ "id", qid;
+ "query", query;
+ "types", types;
+ ]
+ in
+ annotmap, statement::statements
+ ) q_prepared (annotmap, []) in
+ C.list (annotmap, gamma) statements
+ in
+ let annotmap, queries =
+ let annotmap, queries =
+ UpdateMap.fold
+ (fun _ (_, query) (annotmap, queries) ->
+ let annotmap, query = C.string annotmap query in
+ annotmap, query::queries
+ ) u_prepared (annotmap, [])
+ in
+ C.list (annotmap, gamma) queries
+ in
+ let annotmap, pgdb = C.apply gamma annotmap open_ [name; tables; statements; queries] in
+ {env with annotmap}, pgdb
+
+ let pp_type_as_pgtype ?(path=[]) env fmt ty =
+ match StringListMap.find_opt path env.ty_init with
+ | Some (`foreign _) -> assert false
+ | Some (`type_ (name,_)) -> Format.pp_print_string fmt name
+ | None ->
+ match QmlTypesUtils.Inspect.follow_alias_noopt_private env.gamma ty with
+ | Q.TypeConst Q.TyFloat -> Format.fprintf fmt "FLOAT8"
+ | Q.TypeConst Q.TyInt -> Format.fprintf fmt "INT8"
+ | Q.TypeConst Q.TyString -> Format.fprintf fmt "TEXT"
+ | _ ->
+ Format.eprintf "Not_found path [%a]:%a\n%!"
+ (Format.pp_list "," Format.pp_print_string) path
+ QmlPrint.pp#ty ty;
+ raise Not_found
+
+ (* ******************************************************)
+ (* QUERYING *********************************************)
+ (* ******************************************************)
+ let pp_postgres_genquery pp_expr fmt (q:(_, _) QmlAst.Db.query) =
+ let rec aux fmt q =
+ let pp x = Format.fprintf fmt x in
+ match q with
+ | QD.QEq e -> pp " = %a" pp_expr e
+ | QD.QGt e -> pp " > %a" pp_expr e
+ | QD.QLt e -> pp " < %a" pp_expr e
+ | QD.QGte e -> pp " >= %a" pp_expr e
+ | QD.QLte e -> pp " <= %a" pp_expr e
+ | QD.QNe e -> pp " <> %a" pp_expr e
+ | QD.QIn e -> pp " IN %a" pp_expr e
+ | QD.QMod _ -> assert false
+ | QD.QExists false -> pp " = NULL"
+ | QD.QExists true -> pp " <> NULL"
+ | QD.QOr (q0, q1) ->
+ pp "%a OR %a"
+ aux q0
+ aux q1
+ | QD.QAnd (q0, q1) ->
+ pp "%a AND %a"
+ aux q0
+ aux q1
+ | QD.QNot _ -> assert false
+ | QD.QFlds flds ->
+ List.iter
+ (fun (f, q) ->
+ pp "%a %a"
+ pp_postgres_field f
+ aux q
+ ) flds
+ in
+ match q with
+ | QD.QFlds [] -> ()
+ | _ ->
+ let pp x = Format.fprintf fmt x in
+ pp " WHERE ";
+ aux fmt q
+
+ let pp_postgres_sqlquery fmt q =
+ let pos = ref 0 in
+ let pp x = Format.fprintf fmt x in
+ pp "SELECT ";
+ (match q.QD.sql_fds with
+ | [] -> pp "* "
+ | _ ->
+ (BaseFormat.pp_list ","
+ (fun fmt (db, field) ->
+ (match db with "" -> ()
+ | _ -> Format.fprintf fmt "%s." db);
+ Format.fprintf fmt "%s" field
+ ))
+ fmt q.QD.sql_fds
+ );
+ pp " FROM ";
+ (BaseFormat.pp_list "," Format.pp_print_string) fmt q.QD.sql_tbs;
+ match q.QD.sql_ops with
+ | None -> ()
+ | Some sql_ops ->
+ pp_postgres_genquery
+ (fun fmt -> function
+ | `expr _ -> incr pos; Format.fprintf fmt "$%d" !pos
+ | `bind s -> Format.pp_print_string fmt s
+ ) fmt sql_ops
+
+ let prepared_statement_for_query =
+ let fresh_id =
+ let fresh = Fresh.fresh_factory (fun x -> x) in
+ fun () -> Format.sprintf "query_%d" (fresh ())
+ in
+ fun
+ ({annotmap; q_prepared; _} as env)
+ ((sqlquery, options) as query) ->
+ let buffer = Buffer.create 256 in
+ let fmt = Format.formatter_of_buffer buffer in
+ pp_postgres_sqlquery fmt sqlquery;
+ (* TODO OPTIONS *)
+ ignore options;
+ Format.pp_print_flush fmt ();
+ let qid = fresh_id () in
+ let q_prepared = QueryMap.add query (qid, Buffer.contents buffer) q_prepared in
+ {env with annotmap; q_prepared}
+
+ let execute_statement
+ ({gamma; annotmap; q_prepared; _} as env)
+ node (uniq, query) =
+ let qid, _ = try QueryMap.find query q_prepared with
+ Not_found -> OManager.i_error "Can't found prepared statement"
+ in
+ let annotmap, database =
+ C.ident annotmap node.S.database.S.ident node.S.database.S.dbty in
+ let annotmap, qid = C.string annotmap qid in
+ let annotmap, args =
+ match (fst query).QD.sql_ops with
+ | None -> annotmap, []
+ | Some sql_ops ->
+ (* see type Postgres.data *)
+ QmlAstWalk.DbWalk.Query.self_traverse_fold
+ (fun self tra ((annotmap, args) as acc) -> function
+ | QD.QEq (`expr e)
+ | QD.QGt (`expr e)
+ | QD.QLt (`expr e)
+ | QD.QGte (`expr e)
+ | QD.QLte (`expr e)
+ | QD.QNe (`expr e)
+ | QD.QIn (`expr e) ->
+ let annotmap, arg = opa_to_data gamma annotmap e in
+ annotmap, arg::args
+ | QD.QAnd (q0, q1)
+ | QD.QOr (q0, q1) ->
+ self (self acc q0) q1
+ | x -> tra acc x
+ ) (annotmap, []) sql_ops
+ in
+ let annotmap, args = C.rev_list (annotmap, gamma) args in
+ let build = if uniq then Api.Db.build_uniq else Api.Db.build_dbset in
+ let annotmap, build =
+ OpaMapToIdent.typed_val ~label ~ty:[node.S.ty]
+ build annotmap gamma
+ in
+ let annotmap, dbset = C.apply gamma annotmap build [database; qid; args] in
+ {env with annotmap}, dbset
+
+
+ (* ******************************************************)
+ (* UPDATING *********************************************)
+ (* ******************************************************)
+ let pp_update ~tbl pp_expr fmt (u:_ QmlAst.Db.update) =
+ Format.fprintf fmt "UPDATE %s SET " tbl;
+ match u with
+ | QD.UFlds flds ->
+ Format.pp_list ", "
+ (fun fmt (s, u) ->
+ Format.fprintf fmt "%a = " pp_postgres_field s;
+ match u with
+ | QD.UIncr e -> Format.fprintf fmt "%a + %a" pp_postgres_field s pp_expr e;
+ | QD.UExpr e -> Format.fprintf fmt "%a" pp_expr e;
+ | _ -> assert false
+ ) fmt flds
+ | QD.UExpr _
+ | QD.UIncr _ -> assert false
+ | QD.UId _
+ | QD.UAppend _
+ | QD.UAppendAll _
+ | QD.URemove _
+ | QD.URemoveAll _
+ | QD.UPop
+ | QD.UShift ->
+ (* External table? Embedded? Mixed? *)
+ assert false
+
+ let pp_insert ~tbl pp_expr fmt (u:_ QmlAst.Db.update) =
+ match u with
+ | QD.UFlds flds ->
+ Format.fprintf fmt "INSERT INTO %s(%a) VALUES(" tbl
+ (Format.pp_list ", "
+ (fun fmt (s, _u) -> pp_postgres_field fmt s))
+ flds;
+ Format.pp_list ", "
+ (fun fmt (_s, u) ->
+ match u with
+ | QD.UIncr e
+ | QD.UExpr e -> pp_expr fmt e;
+ | _ -> assert false
+ ) fmt flds;
+ Format.fprintf fmt ")"
+ | QD.UExpr _
+ | QD.UIncr _ -> assert false
+ | QD.UId _
+ | QD.UAppend _
+ | QD.UAppendAll _
+ | QD.URemove _
+ | QD.URemoveAll _
+ | QD.UPop
+ | QD.UShift ->
+ (* External table? Embedded? Mixed? *)
+ assert false
+
+ let pp_postgres_insert_or_update env ~name ~tbl fmt q (u:_ QmlAst.Db.update) =
+ let annotmap = env.annotmap in
+ let aset = ref AnnotSet.empty in
+ let pp_annot fmt i = Format.fprintf fmt "x%d" (Annot.to_int i) in
+ let pp_expr fmt e =
+ let annot = Annot.annot (Q.Label.expr e) in
+ aset := AnnotSet.add annot !aset;
+ pp_annot fmt annot
+ in
+ let pp x = Format.fprintf fmt x in
+ pp "CREATE OR REPLACE FUNCTION %s(" name;
+ let buffer = Buffer.create 256 in
+ let fmt2 = Format.formatter_of_buffer buffer in
+ let pp2 x = Format.fprintf fmt2 x in
+ pp2 ")RETURNS VOID AS\n";
+ pp2 "$$\n";
+ pp2 "BEGIN\n";
+ pp2 " LOOP\n";
+ pp2 " %a " (pp_update ~tbl pp_expr) u;
+ begin match q with
+ | Some (q, _) -> pp_postgres_genquery pp_expr fmt2 q;
+ | _ -> ()
+ end;
+ pp2 ";\n";
+ pp2 " IF found THEN\n";
+ pp2 " RETURN;\n";
+ pp2 " END IF;\n";
+ pp2 " BEGIN\n";
+ pp2 " %a;\n" (pp_insert ~tbl pp_expr) u;
+ pp2 " EXCEPTION WHEN unique_violation THEN\n";
+ pp2 " END;\n";
+ pp2 " END LOOP;\n";
+ pp2 "END;\n";
+ pp2 "$$\n";
+ pp2 "LANGUAGE plpgsql;\n";
+ Format.pp_print_flush fmt2 ();
+ let () =
+ let pp_elt fmt a =
+ Format.fprintf fmt "%a %a"
+ pp_annot a
+ (pp_type_as_pgtype env) (QmlAnnotMap.find_ty a annotmap)
+ in
+ let max = AnnotSet.max_elt !aset in
+ let set = AnnotSet.remove max !aset in
+ AnnotSet.pp ", " pp_elt fmt set;
+ pp_elt fmt max
+ in
+ Format.pp_print_string fmt (Buffer.contents buffer);
+ ()
+
+ let prepared_statement_for_update =
+ let fresh_id =
+ let fresh = Fresh.fresh_factory (fun x -> x) in
+ fun () -> Format.sprintf "update_%d" (fresh ())
+ in
+ fun
+ ({annotmap; u_prepared; _} as env)
+ ~tbl
+ query
+ (update, update_options) ->
+ let buffer = Buffer.create 256 in
+ let fmt = Format.formatter_of_buffer buffer in
+ let uid = fresh_id () in
+ pp_postgres_insert_or_update env ~name:uid ~tbl fmt query update;
+ (* TODO OPTIONS *)
+ ignore (update_options);
+ Format.pp_print_flush fmt ();
+ Format.eprintf "%s\n%!" (Buffer.contents buffer);
+ let u_prepared = UpdateMap.add (query, update) (uid, Buffer.contents buffer) u_prepared in
+ {env with annotmap; u_prepared}
+
+ let execute_statement_for_update =
+ fun
+ ({gamma; annotmap; u_prepared; _} as env)
+ node query (update, _update_options) ->
+ let procname, _ = UpdateMap.find (query, update) u_prepared in
+ let amap = AnnotMap.empty in
+ let amap =
+ match query with
+ | None -> amap
+ | Some (query , _) ->
+ QmlAstWalk.DbWalk.Query.fold
+ (fun amap -> function
+ | QD.QEq e | QD.QGt e | QD.QLt e | QD.QGte e | QD.QLte e
+ | QD.QNe e | QD.QIn e ->
+ let annot = Annot.annot (Q.Label.expr e) in
+ AnnotMap.add annot e amap
+ | _ -> amap
+ ) AnnotMap.empty query
+ in
+ let amap =
+ QmlAstWalk.DbWalk.Update.fold
+ (fun amap -> function
+ | QD.UExpr e
+ | QD.UIncr e
+ | QD.UAppend e
+ | QD.UAppendAll e
+ | QD.URemove e
+ | QD.URemoveAll e
+ | QD.UId (e, _) ->
+ let annot = Annot.annot (Q.Label.expr e) in
+ AnnotMap.add annot e amap
+ | _ -> amap
+ ) amap update
+ in
+ let annotmap, database =
+ C.ident annotmap node.S.database.S.ident node.S.database.S.dbty in
+ let annotmap, procname =
+ C.string annotmap procname in
+ let annotmap, args =
+ AnnotMap.fold
+ (fun _ expr (annotmap, args) ->
+ let annotmap, arg = opa_to_data gamma annotmap expr in
+ annotmap, arg::args
+ ) amap (annotmap, [])
+ in
+ let annotmap, args =
+ C.rev_list (annotmap, gamma) args in
+ let annotmap, update_or_insert =
+ OpaMapToIdent.typed_val ~label Api.Db.update_or_insert annotmap gamma in
+ let annotmap, res =
+ C.apply gamma annotmap update_or_insert [database; procname; args] in
+ {env with annotmap}, res
+
+ let query_to_sqlquery tbl query =
+ let rec aux q =
+ let binop q0 q1 rb = rb (aux q0) (aux q1) in
+ match q with
+ | QD.QEq e -> QD.QEq (`expr e)
+ | QD.QGt e -> QD.QGt (`expr e)
+ | QD.QLt e -> QD.QLt (`expr e)
+ | QD.QGte e -> QD.QGte (`expr e)
+ | QD.QLte e -> QD.QLte (`expr e)
+ | QD.QNe e -> QD.QNe (`expr e)
+ | QD.QIn e -> QD.QIn (`expr e)
+ | QD.QMod i -> QD.QMod i
+ | QD.QOr (q0, q1) -> binop q0 q1 (fun q0 q1 -> QD.QOr (q0, q1))
+ | QD.QAnd (q0, q1) -> binop q0 q1 (fun q0 q1 -> QD.QAnd (q0, q1))
+ | QD.QNot q -> QD.QNot (aux q)
+ | QD.QFlds flds ->
+ let flds = List.map (fun (s,q) -> (s, aux q)) flds in
+ QD.QFlds flds
+ | QD.QExists b -> QD.QExists b
+ in
+ {QD. sql_ops = Option.map aux query; sql_tbs = [tbl]; sql_fds = []}
+
+ let resolve_sqlaccess env node (uniq, query) =
+ (* TODO - Prepare for uniq ? *)
+ let env = prepared_statement_for_query env query in
+ execute_statement env node (uniq, query)
+
+ let path ~context
+ ({gamma; schema; _} as env)
+ (label, dbpath, kind, select)
+ =
+ let node = get_node ~context gamma schema dbpath in
+ match node.S.database.S.options.QD.backend with
+ | `postgres ->
+ begin
+ match kind, node.S.kind with
+ | QD.Default, S.SqlAccess query ->
+ resolve_sqlaccess env node (false, query)
+ | QD.Default, S.SetAccess (S.DbSet _, [tbl], query, _) ->
+ let uniq, query =
+ match query with
+ | None ->
+ false, (query_to_sqlquery tbl None, QD.default_query_options)
+ | Some (uniq, (q, o)) ->
+ uniq, (query_to_sqlquery tbl (Some q), o)
+ in
+ resolve_sqlaccess env node (uniq, query)
+ | QD.Update (upd, opt), S.SetAccess (S.DbSet _, [tbl], query, _) ->
+ let query =
+ match query with
+ | None -> None
+ | Some (true, q) -> Some q
+ | _ -> assert false
+ in
+ let env = prepared_statement_for_update env ~tbl query (upd, opt) in
+ execute_statement_for_update env node query (upd, opt)
+ | _ -> assert false
+ end
+ | _ -> env, Q.Path (label, dbpath, kind, select)
+
+ let table
+ ({gamma; tb_init; _} as env)
+ path ty lidx =
+ Format.eprintf "Generating table %a with %a\n%!"
+ pp_table_name path
+ QmlPrint.pp#ty ty;
+ let rec type_from_ty env tpath ty =
+ match ty with
+ | Q.TypeRecord Q.TyRow (fields, _) ->
+ let tra env = List.fold_left
+ (fun env (s, t) -> type_from_ty env (s::tpath) t)
+ env fields
+ in
+ begin match tpath with