Permalink
Browse files

[enhance] compiler, database: Added sub path of multi node

  • Loading branch information...
1 parent 7d90ca8 commit fb519cdbfd1e2f24b69ee8f83a7a3067a014d09d @BourgerieQuentin BourgerieQuentin committed Apr 11, 2012
@@ -1916,14 +1916,10 @@ module CodeGenerator ( Arg : DbGenByPass.S ) = struct
let r = match virtual_ with
| `virtualset (_, wty, false, _) ->
make_virtualset_fullpath ~context db_def.Schema_private.schema dbinfo gamma node path kind wty
- | `virtualset (_, wty, true, record) ->
- begin match record with
- | Some record -> make_virtualset_partialpath
- db_def.Schema_private.schema dbinfo gamma node path kind wty record
- | None ->
- match kind with
- | Db.Ref -> make_ref_path db_def.Schema_private.schema dbinfo gamma node path
- | _ -> get_path_expr db_def.Schema_private.schema dbinfo gamma node path kind
+ | `virtualset (_, _wty, true, _) ->
+ begin match kind with
+ | Db.Ref -> make_ref_path db_def.Schema_private.schema dbinfo gamma node path
+ | _ -> get_path_expr db_def.Schema_private.schema dbinfo gamma node path kind
end
| `virtualpath (ident, rty, wty) ->
make_virtualpath db_def.Schema_private.schema dbinfo gamma node path kind ident rty wty
@@ -1022,7 +1022,7 @@ let rec convert_dbpath ~context t gamma node kind select path0 path =
let new_annots, epath = convert_dbpath ~context t gamma (SchemaGraph.unique_next t node) kind select path0 path in
new_annots, Db.NewKey :: epath
- | Db.Query (query, options)::[] ->
+ | Db.Query (query, options)::path ->
let new_annots, (query, options) =
let ty =
match SchemaGraphLib.type_of_node node with
@@ -1035,9 +1035,8 @@ let rec convert_dbpath ~context t gamma node kind select path0 path =
in
coerce_query_element ~context gamma ty (query, options)
in
- new_annots, [Db.Query (query, options)]
-
- | Db.Query _::_path -> QmlError.error context "sub path after query is not handler yet"
+ 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
let get_virtual_path vpath epath =
let rec aux acc = function
@@ -1079,7 +1078,7 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
match node.C.ty with
| Q.TypeName ([setparam;_], name) when Q.TypeIdent.to_string name = "dbset" ->
let ty = C.Db.set setparam in
- ty, node, `virtualset (setparam, ty, true, None)
+ ty, node, `virtualset (setparam, ty, true, (fun t -> C.Db.set t))
| ty -> ty, node, `realpath
)
| [],_ -> node.C.ty, node, `realpath
@@ -1095,23 +1094,23 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
find_exprpath_aux ~context t ~node:next ~kind ~epath0 vpath epath
| (Db.Query (query, _))::epath, C.Multi ->
let setty = node.C.ty in
- (match epath with
- | [] -> ()
- | _ -> QmlError.error context "Path after queries is not yet allowed");
+ let dataty, dnode, _ =
+ find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node)
+ ~kind ~epath0 vpath epath
+ in
(match setty with
- | Q.TypeName ([setparam; _], name) when Q.TypeIdent.to_string name = "dbset" ->
- let setty = C.Db.set setparam in
- let node, partial, tyread = node, not (is_uniq t node query), setty in
- setty, node, `virtualset (setparam, tyread, partial, None)
+ | Q.TypeName ([_setparam; _], name) when Q.TypeIdent.to_string name = "dbset" ->
+ let setty = C.Db.set dataty in
+ let partial = not (is_uniq t node query) in
+ setty, dnode, `virtualset (dataty, dataty, partial, (fun t -> C.Db.set t))
| _ ->
let keyty = SchemaGraphLib.type_of_key t node in
let partial = not (is_uniq t node query) in
- let valty, node, _x =
- find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node)
- ~kind ~epath0 vpath []
- in Q.TypeName ([keyty; valty], Q.TypeIdent.of_string Opacapi.Types.map), node,
- `virtualset (valty, valty, partial, None)
- )
+ let rebuildt dataty =
+ Q.TypeName ([keyty; dataty], Q.TypeIdent.of_string Opacapi.Types.map)
+ in
+ rebuildt dataty, node, `virtualset (dataty, dataty, partial, rebuildt)
+ )
| (Db.ExprKey _e)::epath, C.Multi ->
find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node) ~kind ~epath0 vpath epath
View
@@ -322,8 +322,11 @@ struct
| NewKey -> pp f "[?]"
| Query (q, o) -> pp f "[%a%a]" (pp_query 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
+
let pp_path pp_expr f (el, knd, select) =
- let pp_el fmt () = pp fmt "%a" (BaseFormat.pp_list "" (pp_path_elt pp_expr)) el in
+ let pp_el fmt () = pp_path_elts pp_expr fmt el in
match knd with
| Update u -> pp f "%a.%a <- %a" pp_el () (pp_select pp_expr) select (pp_update pp_expr) u
| _ ->
View
@@ -60,7 +60,7 @@ module Schema = struct
| Compose of (string * string list) list
| Plain
| Partial of bool (* Inside sum*) * string list * string list
- | SetAccess of set_kind * string list * (bool (*is_unique*) * query) option
+ | SetAccess of set_kind * string list * (bool (*is_unique*) * query) option * QmlAst.path option
type node = {
ty : QmlAst.ty;
@@ -92,14 +92,15 @@ module Schema = struct
| Compose cmp ->
Format.fprintf fmt "compose(%a)"
(Format.pp_list "; " (fun fmt (f, p) -> Format.fprintf fmt "%s:[%a]" f pp_path p)) cmp
- | SetAccess (sk, path, query) ->
- Format.fprintf fmt "@[<hov>access to %a : %a with %a@]"
+ | SetAccess (sk, path, query, epath) ->
+ Format.fprintf fmt "@[<hov>access to %a : %a @. with %a @. embedded path : %a@]"
pp_path path
pp_set_kind sk
pp_query query
+ (Option.pp (DbAst.pp_path_elts QmlPrint.pp#expr)) epath
let pp_node fmt node =
- Format.fprintf fmt "{@[<hov>type : %a; kind : %a; ...@]}"
+ Format.fprintf fmt "{@[<hov>type : %a; @. kind : %a; ...@]}"
QmlPrint.pp#ty node.ty
pp_kind node.kind
@@ -244,7 +245,7 @@ module Schema = struct
in
let database = get_database schema dbname in
let llschema = declaration.Sch.schema in
- let f (node, kind, path) fragment =
+ 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
@@ -265,14 +266,14 @@ module Schema = struct
| DbAst.ExprKey expr ->
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))) in
+ let kind = SetAccess (setkind, path, Some (true, (DbAst.QEq expr, options)), None) in
(next, kind, path)
| DbAst.FldKey key ->
let kind =
let nlabel = Graph.V.label next in
match nlabel.C.nlabel with
- | C.Multi -> SetAccess (get_setkind llschema next, key::path, None)
+ | C.Multi -> SetAccess (get_setkind llschema next, key::path, None, None)
| _ ->
match kind, nlabel.C.plain with
| Compose _, true -> Plain
@@ -285,20 +286,26 @@ module Schema = struct
in (next, kind, path)
| DbAst.Query (query, options) ->
begin match kind with
- | SetAccess (_k, path, None) ->
- let partial = Sch.is_uniq llschema node query in
+ | SetAccess (_k, path, None, _) ->
+ let uniq = Sch.is_uniq llschema node query in
let kind = SetAccess (get_setkind llschema node, path,
- Some (partial, (query, options))) in
+ Some (uniq, (query, options)), None) in
(next, kind, path)
- | SetAccess (_, _path, Some _) ->
+ | SetAccess (_, _path, Some _, _) ->
raise (Base.NotImplemented "Selection inside a multi node")
| _ ->
raise (Base.NotImplemented "Query in a non multi node")
end
| DbAst.NewKey -> raise (Base.NotImplemented "New key")
in
- let (node, kind, _path) =
- List.fold_left f (get_root llschema, Compose [], []) path 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)
+ | t::q, _ -> find q (find_next_step x t)
+ in find path (get_root llschema, Compose [], [])
+ in
let kind =
match kind with
| Compose _ -> (
@@ -318,14 +325,14 @@ module Schema = struct
)
| Partial (sum, path, part) ->
Partial (sum, List.rev path, List.rev part)
- | SetAccess (k, path, query) ->
- SetAccess (k, List.rev path, query)
+ | SetAccess (k, path, query, epath) ->
+ SetAccess (k, List.rev path, query, epath)
| Plain -> Plain
in
let default =
let node =
match kind with
- | SetAccess (_, _, None) -> SchemaGraphLib.SchemaGraph.unique_next llschema node
+ | SetAccess (_, _, None, _) -> SchemaGraphLib.SchemaGraph.unique_next llschema node
| _ -> node
in
fun annotmap ->
@@ -68,7 +68,7 @@ module Schema: sig
| Compose of (string * string list) list
| Plain
| Partial of bool * string list * string list
- | SetAccess of set_kind * string list * (bool * query) option (*bool == unique*)
+ | SetAccess of set_kind * string list * (bool * query) option (*bool == unique*) * QmlAst.path option
type node = {
ty : QmlAst.ty;

0 comments on commit fb519cd

Please sign in to comment.