Skip to content
Newer
Older
100644 404 lines (338 sloc) 14.9 KB
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 (**
20 Private module for DB-Schema manipulation.
21 @author Louis Gesbert
22 @author Vincent Benayoun (refactoring)
23 *)
24
25 (* This module gathers generic functions for schema graphs. *)
26
27
28 (* shorthand *)
29 module Q = QmlAst
30 module C = DbGen_common
31
32 (* alias *)
33 module Db = Q.Db
34
35 let internal_error fmt = OManager.i_error fmt
36
37 module Vertices: Graph.Sig.COMPARABLE with type t = C.schema_node = struct
38 type t = C.schema_node
39 let equal n1 n2 = (n1.C.nodeid = n2.C.nodeid)
40 let hash n = Hashtbl.hash n.C.nodeid
41 let compare n1 n2 = Pervasives.compare n1.C.nodeid n2.C.nodeid
42 end
43 module Edges: Graph.Sig.ORDERED_TYPE_DFT with type t = C.schema_edge = struct
44 type t = C.schema_edge
45 let compare = compare
46 let hash = Hashtbl.hash
47 let equal = (=)
48 let default = { C.label = C.Field ("",0); C.is_main = false }
49 end
50
51 module SchemaGraph = GraphLib.SchemaGraph (Vertices) (Edges)
52 module V = SchemaGraph.V
53 module E = SchemaGraph.E
54 module SchemaGraph0 = SchemaGraph.SchemaGraph0
55
56 let is_root n = (V.label n).C.nodeid = "root"
57
58 let get_parent_edge t node =
59 if is_root node then raise Not_found else
60 match SchemaGraph0.pred_e t node with
61 | [] -> internal_error "get_parent_edge: node in DB schema has no parent"
62 | p::[] -> p
63 | pl ->
64 match List.find_all (fun e -> (E.label e).C.is_main) pl with
65 | [p] -> p
66 | [] -> internal_error "get_parent_edge: node in DB schema has no distinguished parent"
67 | _ -> internal_error "get_parent_edge: node in DB schema has multiple distinguished parents"
68
69 let get_parent_node t node = E.src (get_parent_edge t node)
70
71 let string_of_edge e = match (E.label e).C.label with
72 | C.Field (s,_) -> s
73 | C.SumCase _ -> "."
74 | C.Hidden_edge _ -> ""
75 | C.Multi_edge _ -> "_"
76
77 let node_label n = (V.label n).C.nlabel
78
79 let type_of_node n = (V.label n).C.ty
80
81 let package_of_node n = (V.label n).C.from_package
82
83 let type_of_leaf = function
84 | C.Leaf_int -> Q.TypeConst Q.TyInt
85 | C.Leaf_float -> Q.TypeConst Q.TyFloat
86 | C.Leaf_text -> Q.TypeConst Q.TyString
87 | C.Leaf_binary -> Q.TypeConst Q.TyString
88
89 let leaves = [C.Leaf_int; C.Leaf_float; C.Leaf_text; C.Leaf_binary]
90
91
92 (***)
93
94 let fieldname_of_edge e = match (E.label e).C.label with
95 | C.Field (f,_) -> f
96 | _ -> assert false
97
98 let fieldid_of_edge e = match (E.label e).C.label with
99 | C.SumCase id | C.Field (_,id) -> id
100 | _ -> assert false
101
102 let path_of_node_one_step ~acc t ?(dir=None) node =
103 if Some node = dir || is_root node then None
104 else
105 let pred_e = get_parent_edge t node in
106 let acc =
107 match (E.label pred_e).C.label with
108 | C.Field (s,_) -> Db.Decl_fld s :: acc
109 | C.SumCase _ -> acc
110 | C.Hidden_edge -> acc
111 | C.Multi_edge C.Kint -> Db.Decl_int :: acc
112 | C.Multi_edge C.Kstring -> Db.Decl_string :: acc
113 | C.Multi_edge (C.Kfields _) -> Db.Decl_set [] :: acc in
114 Some (E.src pred_e, acc)
115
116 let rec path_of_node acc t ?dir node =
117 match path_of_node_one_step ~acc t ?dir node with
118 | None -> acc
119 | Some (node, acc) -> path_of_node acc t ?dir node
120
121 let path_to_string = String.concat "/"
122
123 let string_path_of_node t ?dir node =
124 (* (match dir with Some n when not is_root n -> "" | _ -> "/") ^ *)
125 Db.path_decl_to_string (path_of_node [] t ~dir node)
126
127 let edge_is_fld fld e = match (E.label e).C.label with
128 | C.Field (s,_) -> s = fld
129 | _ -> false
130
131
132 (* handles only record paths (as they are in the initial tree). Raises Not_found *)
133 (** Follow a path in a schema started from a given node *)
134 let rec find_raw_path ~context t cur_node path = match path with
135 | [] -> cur_node
136 | (Db.Decl_fld str)::next_path ->
137 let chlds = SchemaGraph0.succ_e t cur_node in
138 let edge = List.find (edge_is_fld str) chlds
139 in find_raw_path ~context t (E.dst edge) next_path
140 | (Db.Decl_set [])::_next_path ->
141 QmlError.error context
142 "Path specification with set index being implemented in (find_raw_path)"
143 | _ ->
144 QmlError.error context
145 "Path specification with something else than field names unhandled yet"
146
147 let rec find_field_edge t node field =
148 match
149 match (V.label node).C.nlabel with
150 | C.Product ->
151 List.find_all (edge_is_fld field) (SchemaGraph0.succ_e t node)
152 | C.Sum ->
153 List.find_all
154 (fun e ->
155 try ignore (find_field_edge t (E.dst e) field); true
156 with Not_found -> false)
157 (SchemaGraph0.succ_e t node)
158 | _ -> raise (Invalid_argument "find_field_edge")
159 with
160 | [e] -> e
161 | [] -> raise Not_found
162 | _ ->
163 QmlError.error (V.label node).C.context (
164 "@[<2>This data query is ambiguous (it may match several cases in a sum type):@\n"^^
165 "%s/%s@]"
166 )
167 (string_path_of_node t node)
168 field
169
170
171 (** @return the key of a Mult node *)
172 let multi_key t n =
173 match List.map E.label (SchemaGraph0.succ_e t n) with
174 | [{C.label = C.Multi_edge k}] -> k
175 (* TODO: adapt to sets with multiple keys *)
176 | _ -> assert false
177
178 (** @return the key type of a Mult node *)
179 let type_of_key t n = match multi_key t n with
180 | C.Kint -> Q.TypeConst Q.TyInt
181 | C.Kstring -> Q.TypeConst Q.TyString
182 | C.Kfields [fldlist] -> (* todo *)
183 let node_of_elts = List.hd (SchemaGraph0.succ t n) in
184 let chld_types = List.map (fun fld -> fld, (E.dst (find_field_edge t node_of_elts fld)).C.ty) fldlist in
185 Q.TypeRecord (QmlAstCons.Type.Row.make ~extend:false chld_types)
186 | C.Kfields _ -> assert false (* todo: handle multiple keys of sets *)
187
188 (** [type_of_partial_key fields schema node] For a set [node] and a
189 key that contains [fields] returns the type of key fields and the
190 type of free fields. *)
191 let type_of_partial_key fields t n = match multi_key t n with
192 | C.Kfields [fldlist] ->
193 let node_of_elts = List.hd (SchemaGraph0.succ t n) in
194 let fields =
195 List.sort
196 (fun x y -> String.compare (fst x) (fst y))
197 fields in
198 let fldlist = List.sort String.compare fldlist in
199 let _, tykeys, tyfreekeys =
200 List.fold_left
201 (fun (fields, tykeys, tyfreekeys) fld ->
202 let tyfld =
203 (fld, (E.dst (find_field_edge t node_of_elts fld)).C.ty) in
204 match fields with
205 | [] -> ([], tykeys, tyfld::tyfreekeys)
206 | (f,_)::rfields when f = fld -> (rfields, tyfld::tykeys, tyfreekeys)
207 | _ -> (fields, tykeys, tyfld::tyfreekeys)
208 ) (fields, [], []) fldlist in
209 tykeys, tyfreekeys
210 | C.Kint | C.Kstring | C.Kfields _ -> internal_error "type_of_partial_key"
211
212
213 let rec get_root ?n t =
214 let n = match n with Some n -> n | None -> SchemaGraph.get_node t in
215 if is_root n then n else get_root ~n:(E.src (get_parent_edge t n)) t
216
217 (** Finds the node pointed by a given path *)
218 let rec find_path t ?(node=get_root t) path = match path with
219 | [] -> node
220 (* | "."::path -> find_path t ~node path *)
221 | it::path ->
222 match (V.label node).C.nlabel, it with
223 | C.Leaf _, _ ->
224 raise Not_found
225 | C.Product, Db.Decl_fld fld ->
226 let next_e =
227 List.find (edge_is_fld fld) (SchemaGraph0.succ_e t node)
228 in find_path t ~node:(E.dst next_e) path
229 | C.Sum, Db.Decl_fld fld ->
230 let e = find_field_edge t node fld in
231 find_path t ~node:(E.dst e) (it::path)
232 | C.Hidden, _ ->
233 find_path t ~node:(SchemaGraph.unique_next t node) (it::path)
234 | C.Multi, decl ->
235 (match decl, multi_key t node with
236 | Db.Decl_int, C.Kint | Db.Decl_string, C.Kstring | Db.Decl_set _, C.Kfields _
237 | Db.Decl_set [], _ -> (* we allow /path[] whatever the key should be for find_path *)
238 find_path t ~node:(SchemaGraph.unique_next t node) path
239 | _, _ -> raise Not_found)
240 | _, _ -> raise Not_found
241 (* else try *)
242 (* match next_e.label with *)
243 (* | C.Multi_int None -> ignore (int_of_string it); find_path ~generic t (E.dst next_e) path *)
244 (* | C.Multi_float None -> ignore (float_of_string it); find_path ~generic t (E.dst next_e) path *)
245 (* | C.Multi_string None -> ; find_path ~generic t (E.dst next_e) path *)
246 (* | _ -> find_path ~generic t (E.dst next_e) (it::path) (\* there is a default value *\) *)
247 (* with Failure _ -> sch_error (sprintf "invalid key type in path %s" *)
248 (* (string_path_of_node node)) *)
249
250 (*
251 [find_path_path_of_node schema node] has the same behaviour as
252 [find_path schema ~node (path_of_node schema node)] except that
253 it won't fail when path_of_node returns an ambiguous path
254 as is the case in [db /plop : {a:list(string); b:string} / {a:list(string)}]
255 (because of /plop/a)
256 This function is not the identity because it goes (for instance) through Hidden
257 nodes
258 *)
259 let find_path_path_of_node t ~node =
260 match path_of_node_one_step ~acc:[] t node with
261 | None -> node
262 | Some (node, path) -> find_path t ~node path
263
264 let new_node label ty default constraints context =
265 V.create {
266 C.from_package = ObjectFiles.get_current_package_name();
267 C.nodeid = SchemaGraph.new_nodeid();
268 C.nlabel = label;
269 C.ty = ty;
270 C.default = default;
271 C.constraints = constraints;
272 C.context = context;
28521d4 @BourgerieQuentin [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
BourgerieQuentin authored Jan 24, 2012
273 C.plain = false;
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
274 }
275
276
277 let is_node_abstract node = List.mem Db.C_Private (V.label node).C.constraints
278
279 (* A node is considered private when its _parent_ is abstract (eg has the
280 private constraint). The parent may still be seen, but the 'private' child
281 should be invisible *)
282 let is_node_private t node = if is_root node then false else is_node_abstract (get_parent_node t node)
283
284 (** @param n a Mult node
285 @return true if n is a set node *)
286 let is_node_set t n =
287 match multi_key t n with
288 | C.Kfields _ -> true
289 | _ -> false
290
291 let add_unknown_node ?(ty=Q.TypeRecord (Q.TyRow ([], None))) ?dflt ?(cstr=[]) ~context t parent edgelbl =
292 (* assumes lbl is not already taken *)
293 let cstr = if not (List.mem Db.C_Private cstr) && is_node_abstract parent then Db.C_Private::cstr else cstr in
294 let new_node = new_node C.Product ty dflt cstr context in
295 let new_edge = E.create parent { C.label = edgelbl; C.is_main = true } new_node in
296 SchemaGraph0.add_edge_e t new_edge, new_node
297
298 let set_node_label t node lbl =
299 if lbl = (V.label node).C.nlabel || ((V.label node).C.nlabel = C.Product && SchemaGraph0.succ_e t node = [])
300 then
301 let nnode = V.create { (V.label node) with C.nlabel = lbl } in
302 SchemaGraph.replace_node t node nnode, nnode
303 else
304 internal_error "re-setting a node which is already set: %s" (string_path_of_node t node)
305
306 let set_node_id t node id =
307 let nnode = V.create { (V.label node) with C.nodeid = id } in
308 SchemaGraph.replace_node t node nnode, nnode
309
310 let set_node_type t node ty =
311 let nnode = V.create { (V.label node) with C.ty = ty } in
312 SchemaGraph.replace_node t node nnode, nnode
313
314 let set_node_dflt t node expr =
315 let nnode = V.create { (V.label node) with C.default = Some expr } in
316 SchemaGraph.replace_node t node nnode, nnode
317
318 let set_node_context t node context =
319 let nnode = V.create { (V.label node) with C.context = context } in
320 SchemaGraph.replace_node t node nnode, nnode
321
322 let set_node_cstrs t node cstrs =
323 let nnode = V.create { (V.label node) with C.constraints = cstrs } in
324 SchemaGraph.replace_node t node nnode, nnode
325
28521d4 @BourgerieQuentin [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
BourgerieQuentin authored Jan 24, 2012
326 let set_node_plain t node plain =
327 let nnode = V.create { (V.label node) with C.plain = plain } in
328 SchemaGraph.replace_node t node nnode, nnode
329
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
330 let add_node_cstr t node cstr =
331 (* fixme: check for duplicate/inconsistent constraints *)
332 set_node_cstrs t node ((V.label node).C.constraints @ [cstr])
333
334 let get_node_type node = (V.label node).C.ty
335
336 (** @return n, the succesor of [node] pointed by the edge labeled [key]. *)
337 let get_field_chld t key node =
338 E.dst (List.find (edge_is_fld key) (SchemaGraph0.succ_e t node))
339
340 let upper_nodes t (loop: E.t list) : V.t list =
341 let nodes = List.map E.src loop in
342 List.filter (fun n -> not (List.mem (get_parent_node t n) nodes)) nodes
343
344 let rec equal_subtree (t1,root1) (t2,root2) =
345 V.label root1 = V.label root2 &&
346 let es1 = SchemaGraph0.succ_e t1 root1 and es2 = SchemaGraph0.succ_e t2 root2 in
347 try
348 List.fold_left2
349 (fun acc e1 e2 -> acc && E.label e1 = E.label e2 &&
350 ((E.label e1).C.is_main && equal_subtree (t1,E.dst e1) (t2,E.dst e2)) ||
351 (V.label (E.dst e1) = (V.label (E.dst e2)) (* links -> point to same node *)))
352 true es1 es2
353 with Invalid_argument _ -> false
354
355 (*----------------- Functions for building schema in a progressive way -----------------*)
356 (* and be able to get types before the whole process is finished -> needed by the typer *)
357
358 let initial_root ~context = V.create {
359 C.from_package = ObjectFiles.get_current_package_name();
360 C.nodeid = "root";
361 C.nlabel = C.Product;
362 C.ty = Q.TypeRecord (QmlAstCons.Type.Row.make ~extend:true []);
363 C.default = None;
364 C.constraints = [];
365 C.context = context;
28521d4 @BourgerieQuentin [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
BourgerieQuentin authored Jan 24, 2012
366 C.plain = false;
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
367 }
368
369 let initial_schema ~context = SchemaGraph0.add_vertex SchemaGraph0.empty (initial_root ~context)
370
371 (* Adds the subtree of t' rooted at n to t. The two graphs should be disjoint,
372 except for n that must exist in both *)
373 let rec add_subtree t t' n =
374 SchemaGraph0.fold_succ_e
375 (fun e t ->
376 let t = SchemaGraph0.add_edge_e t e in
377 if (E.label e).C.is_main then add_subtree t t' (E.dst e) else t)
378 t' n t
379
380 let schema_of_package t package_name =
381 SchemaGraph.filter (fun n -> n.C.from_package = package_name || is_root n) t
382
383 let merge_schema t1 t2 =
384 if SchemaGraph0.nb_vertex t1 <= 1 then t2
385 else if SchemaGraph0.nb_vertex t2 <= 1 then t1
386 else
387 let root1, root2 = (get_root t1, get_root t2) in
388 let labels1 =
389 SchemaGraph0.fold_succ_e (fun e acc -> StringSet.add (fieldname_of_edge e) acc) t1 root1 StringSet.empty in
390 SchemaGraph0.fold_succ_e
391 (fun e t ->
392 if StringSet.mem (fieldname_of_edge e) labels1
393 then
394 QmlError.error
395 (QmlError.Context.merge2
396 (V.label (E.dst (find_field_edge t1 root1 (fieldname_of_edge e)))).C.context
397 (V.label (E.dst e)).C.context)
398 "Redefinition of the database root /%s. Two packages can not define database roots with the same name."
399 (fieldname_of_edge e)
400 else
401 let t = SchemaGraph0.add_edge_e t (E.create root1 (E.label e) (E.dst e)) in
402 add_subtree t t2 (E.dst e))
403 t2 root2 t1
Something went wrong with that request. Please try again.