Skip to content

Commit

Permalink
[sqlquery]
Browse files Browse the repository at this point in the history
  • Loading branch information
@BourgerieQuentin
BourgerieQuentin committed Jan 7, 2013
1 parent deb8738 commit afc392d
Show file tree
Hide file tree
Showing 6 changed files with 129 additions and 45 deletions.
25 changes: 17 additions & 8 deletions compiler/libqmlcompil/dbGen/schema_private.ml
View file
Expand Up @@ -905,23 +905,29 @@ let fields_of_sqldata schema node {Db. sql_fds=_; sql_tbs; sql_ops=_} =
)
[] sql_tbs

let coerce_query_element ~context gamma ty (query, options) =
let coerce new_annots wrap ty expr =
let coerce_query_element ~qwrap ~quwrap ~context gamma ty (query, options) =
let simple_coerce new_annots wrap ty expr =
let e = QmlAstCons.UntypedExpr.coerce expr ty in
Q.QAnnot.expr e::new_annots, wrap e
in
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 =
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))
(fun a -> simple_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))
(fun a -> simple_coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
a options.Db.skip
in let a, sort =
let ty =
Expand All @@ -936,7 +942,7 @@ let coerce_query_element ~context gamma ty (query, options) =
optmap
(fun a fields ->
List.fold_left_map
(fun a (flds, e) -> coerce a (fun e -> (flds, e)) ty e)
(fun a (flds, e) -> simple_coerce a (fun e -> (flds, e)) ty e)
a fields
) a options.Db.sort
in
Expand Down Expand Up @@ -1075,7 +1081,8 @@ 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
Expand All @@ -1089,7 +1096,9 @@ let rec convert_dbpath ~context t gamma node kind select path0 path =
in
let ty = Q.TypeRecord (Q.TyRow (fields, None)) in
let new_annots, (sql_ops, options) =
coerce_query_element ~context gamma ty (sql_ops, options)
let qwrap x = `expr x in
let quwrap = function | `expr e -> e | _ -> raise Not_found in
coerce_query_element ~qwrap ~quwrap ~context gamma ty (sql_ops, options)
in
new_annots, (Db.SQLQuery ({Db.sql_tbs; sql_fds; sql_ops}, options))::[]

Expand Down Expand Up @@ -1198,7 +1207,7 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
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, `virtualset (dataty, dataty, partial, rebuildt)
rebuildt dataty, node, `virtualset (dataty, dataty, partial, rebuildt)
| (Db.ExprKey _)::epath, C.Multi ->
aux_multi epath false
| (Db.FldKey fld)::_rp, C.Sum ->
Expand Down
77 changes: 47 additions & 30 deletions compiler/libqmlcompil/qmlAst.ml
View file
Expand Up @@ -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
Expand All @@ -154,16 +154,16 @@ 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 query;
sql_ops : ('expr, [`expr of 'expr | `bind of string]) query;
}

type 'expr query_options = {
Expand Down Expand Up @@ -226,7 +226,7 @@ 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
Expand Down Expand Up @@ -282,12 +282,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
Expand Down Expand Up @@ -324,8 +324,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
Expand All @@ -334,13 +333,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
Expand Down Expand Up @@ -376,21 +382,27 @@ struct
| _ ->
(BaseFormat.pp_list ","
(fun fmt (db, field) ->
match db with "" -> ()
| _ -> pp fmt "%s," db; pp fmt "%s" field))
fmt
sql_fds
(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;
(pp_query pp_expr) fmt 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 =
Expand Down Expand Up @@ -554,7 +566,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)
Expand All @@ -567,17 +579,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
Expand All @@ -596,13 +608,18 @@ 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 (sub_db_query sub_e sub_ty) (sub_db_query_options sub_e sub_ty)
(TU.sub_2 (sub_db_query sub_e sub_eq sub_ty) (sub_db_query_options sub_e sub_ty)
(sql_ops, o)
)

Expand Down
4 changes: 2 additions & 2 deletions compiler/libqmlcompil/qmlDbGen.ml
View file
Expand Up @@ -53,7 +53,7 @@ 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 set_kind =
| Map of QmlAst.ty * QmlAst.ty
Expand All @@ -76,7 +76,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

Expand Down
4 changes: 2 additions & 2 deletions compiler/libqmlcompil/qmlDbGen.mli
View file
@@ -1,5 +1,5 @@
(*
Copyright © 2011, 2012 MLstate
Copyright © 2011, 2012, 2013 MLstate
This file is part of Opa.
Expand Down Expand Up @@ -58,7 +58,7 @@ 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 set_kind =
| Map of QmlAst.ty * QmlAst.ty
Expand Down
1 change: 1 addition & 0 deletions compiler/libtrx/pgrammar.ml
View file
Expand Up @@ -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
Expand Down
63 changes: 60 additions & 3 deletions compiler/opalang/classic_syntax/parser_path.trx
View file
Expand Up @@ -241,6 +241,63 @@ query_field <- query_nokeywords field_long:f query_simple:q
query_fields <- (=list1(query_field, Opa_parser.record_fields_separator)):l Opa_parser.record_fields_separator?
{{ QmlAst.Db.QFlds l }}

(* ******************************************************************)
(**
{7 SQL querying }
Note : Duplication from "Path querying" because TRX restriction (recursive
function)
*)
sqlquery <-
/ sqlquery_combine
/ sqlquery_nocombine

sqlquery_not <- (=Opa_lexer.exact_ident("not")) spacing sqlquery_nocombine:q
{{ QmlAst.Db.QNot q }}

sqlquery_nocombine <-
/ Opa_lexer.lpar sqlquery:q Opa_lexer.rpar {{ q }}
/ sqlquery_simple
/ sqlquery_not
/ sqlquery_fields

sqlquery_combine <-
/ sqlquery_nocombine:q1 spacing sqlquery_double_builder:b spacing sqlquery:q2 {{ b q1 q2 }}
/ Opa_lexer.lpar sqlquery:q1 Opa_lexer.rpar spacing sqlquery_double_builder:b spacing sqlquery:q2 {{ b q1 q2 }}

sqlquery_simple_builder <-
/ (=Opa_lexer.exact_symbol("==")) {{ fun e -> QmlAst.Db.QEq e }}
/ (=Opa_lexer.exact_symbol(">")) {{ fun e -> QmlAst.Db.QGt e }}
/ (=Opa_lexer.exact_symbol("<")) {{ fun e -> QmlAst.Db.QLt e }}
/ (=Opa_lexer.exact_symbol(">=")) {{ fun e -> QmlAst.Db.QGte e }}
/ (=Opa_lexer.exact_symbol("<=")) {{ fun e -> QmlAst.Db.QLte e }}
/ (=Opa_lexer.exact_symbol("!=")) {{ fun e -> QmlAst.Db.QNe e }}
/ (=Opa_lexer.exact_ident("in")) {{ fun e -> QmlAst.Db.QIn e }}

sqlquery_simple <-
/ sqlquery_simple_builder:b sqlquery_expr:e {{ b e }}
/ (=Opa_lexer.exact_ident("exists")) {{ QmlAst.Db.QExists true }}

sqlquery_keywords <-
/ (=Opa_lexer.exact_keyword("and"))
/ (=Opa_lexer.exact_keyword("or"))

sqlquery_nokeywords <-
/ !sqlquery_keywords

sqlquery_double_builder <-
/ (=Opa_lexer.exact_keyword("and")) {{ fun q1 q2 -> QmlAst.Db.QAnd (q1, q2) }}
/ (=Opa_lexer.exact_keyword("or")) {{ fun q1 q2 -> QmlAst.Db.QOr (q1, q2) }}

sqlquery_expr <-
/ spacing Opa_lexer.field_identifier_nosp:s {{`bind s}}
/ Opa_parser.expr:e {{`expr e}}

sqlquery_field <- sqlquery_nokeywords field_long:f sqlquery_simple:q
{{ (f, q) }}

sqlquery_fields <- (=list1(sqlquery_field, Opa_parser.record_fields_separator)):l Opa_parser.record_fields_separator?
{{ QmlAst.Db.QFlds l }}

(* ******************************************************************)
(**
{7 Path SQL querying }
Expand All @@ -254,10 +311,10 @@ sqlfields <- (=list1(sqlfield, Opa_lexer.comma))
sqltables <- (=list1(spacing Opa_lexer.field_identifier_nosp:s {{s}}, Opa_lexer.comma))

;/** SQL Query **/
sqlquery <-
sqlquery1 <-
(=Opa_lexer.exact_keyword("SELECT")) spacing sqlfields:f spacing
(=Opa_lexer.exact_keyword("FROM")) spacing sqltables:t spacing
(=Opa_lexer.exact_keyword("WHERE")) spacing query:q spacing
(=Opa_lexer.exact_keyword("WHERE")) spacing sqlquery:q spacing
{{
{QmlAst.Db.sql_ops = q; sql_fds = f; sql_tbs = t}
}}
Expand Down Expand Up @@ -301,7 +358,7 @@ query_options <-
}}

query_with_options <-
/ sqlquery:q
/ sqlquery1:q
{{
let options = QmlAst.Db.default_query_options in
QmlAst.Db.SQLQuery (q, options)
Expand Down

0 comments on commit afc392d

Please sign in to comment.