Skip to content
Newer
Older
100644 417 lines (374 sloc) 15.4 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 @author Louis Gesbert
20 **)
21
22 (* depends *)
23 module String = BaseString
24 module List = BaseList
25
26 (* Shorthands *)
27 module G = Gml_parser
28
29 (** This module imports graphs as stored by the db (cf
30 libqmlcompil/dbGen/schema_io.ml). The definition is close but different from
31 that in dbGen_common.ml (only information that is meaningful at run-time is available).
32 Although, now that this module is out of the BSL, it would be quite nice to factorise
33 at least the printer/parser between compile-time and run-time.
34
35 We have two types for the schema below: one using sets of vertices and
36 edges, useful when (un-)serialising; and one that looks like a tree, much
37 easier to manipulate.
38 *)
39
40 let version = 9 (* Should be the same as in libqmlcompil/dbGen/DbGen_common *)
41
42 type leaf = Leaf_int | Leaf_float | Leaf_text | Leaf_binary
43
44 type node = Multi | Hidden | Sum | Product | Leaf of leaf
45
46 type multi_key = Kint | Kstring | Kfields of string list list
47
48 type edge_label = Multi_edge of multi_key | Hidden_edge | SumCase of int | Field of string * int | Dead of int
49 (** Dead is for edge ids that have already been used in the past, and should therefore not be used
50 again if we want a consistent history *)
51
52 type edge = { src: string; dst: string; primary: bool; lbl: edge_label }
53
54 (* First representation of schemas used for (un)serialization
55 cf. type tree for the other representation *)
56 (* nodeid of Root has to be "root" *)
57 type schema = {
58 nodes: node StringMap.t;
59 edges: edge list;
60 }
61
62 module StringOf = struct
63 let leaf = function
64 | Leaf_int -> "int" | Leaf_float -> "float" | Leaf_text -> "text" | Leaf_binary -> "binary"
65 let node = function
66 | Multi -> "Multi"
67 | Hidden -> "Hidden"
68 | Sum -> "Sum"
69 | Product -> "Product"
70 | Leaf lf -> Printf.sprintf "Leaf %s" (leaf lf)
71 let multi_key = function
72 | Kint -> "Kint"
73 | Kstring -> "Kstring"
74 | Kfields flds -> Printf.sprintf "Kfields %s"
75 (String.concat_map ~left:"[ " ~right:" ]" "; "
76 (String.concat_map ~left:"[ " ~right:" ]" "; " (fun x -> x))
77 flds)
78 let edge_label = function
79 | Multi_edge mk -> Printf.sprintf "Multi_edge %s" (multi_key mk)
80 | Hidden_edge -> "Hidden_edge"
81 | SumCase i -> Printf.sprintf "SumCase %d" i
82 | Field (s,i) -> Printf.sprintf "Field %s %d" s i
83 | Dead i -> Printf.sprintf "Dead %d" i
84 end
85
86 let node s n = StringMap.find n s.nodes
87
88 let check s = List.fold_left
89 (* uncomplete (missing: connected, edges with distinct ids, one incoming primary, root...) *)
90 (fun acc -> function { src = src; dst = dst; lbl = lbl } ->
91 acc && StringMap.mem src s.nodes && StringMap.mem dst s.nodes &&
92 (match lbl with
93 | Multi_edge _ -> node s src = Multi
94 | Hidden_edge -> node s src = Hidden
95 | SumCase _ -> node s src = Sum
96 | Field _ -> node s src = Product
97 | Dead _ -> true))
98 true s.edges
99
100 let is_root n = n = 0
101 let succ_e s n = List.filter (fun e -> e.src = n) s.edges
102 let pred_e s n = List.filter (fun e -> e.dst = n) s.edges
103 let (@*) = InfixOperator.(@*)
104
105 let edge_num e = match e with SumCase i | Field (_,i) | Dead i -> i | _ -> assert false
106
107 exception Error
108
109 let import_schema s =
110 let r_int params lbl =
111 match List.assoc_opt lbl params with Some (G.Int i) -> i | _ -> raise Error in
112 let r_string params lbl =
113 match List.assoc_opt lbl params with Some (G.String s) -> s | _ -> raise Error in
114 let _pos, gml = G.parse_gml_parser_gml s in
115 let sch = { nodes = StringMap.empty; edges = [] }
116 in
117 (* if n < String.length s then raise Error; *)
118 match gml with
119 | G.List ["graph", G.List elts] ->
120 let sch, idmap = (* parse nodes *)
121 List.fold_left
122 (fun (sch, idmap) n -> match n with
123 | "node", G.List params ->
124 let id = r_int params "id"
125 and nodeid = r_string params "nodeid"
126 and nlabel = match List.assoc_opt "nlabel" params with
127 | Some (G.String "Multi") -> Multi
128 | Some (G.String "Hidden") -> Hidden
129 | Some (G.String "Sum") -> Sum
130 | Some (G.String "Product") -> Product
131 | Some (G.List ["Leaf", G.String "int"]) -> Leaf Leaf_int
132 | Some (G.List ["Leaf", G.String "float"]) -> Leaf Leaf_float
133 | Some (G.List ["Leaf", G.String "text"]) -> Leaf Leaf_text
134 | Some (G.List ["Leaf", G.String "binary"]) -> Leaf Leaf_binary
135 | _ -> raise Error
136 in
137 { sch with nodes = StringMap.add nodeid nlabel sch.nodes },
138 IntMap.add id nodeid idmap
139 | "edge", _ -> sch, idmap
140 | _ -> raise Error)
141 (sch, IntMap.empty)
142 elts
143 in
144 let sch = (* parse edges *)
145 List.fold_left
146 (fun sch n -> match n with
147 | "node", _ -> sch
148 | "edge", G.List params ->
149 let source = IntMap.find (r_int params "source") idmap
150 and target = IntMap.find (r_int params "target") idmap
151 and ismain = 0 <> r_int params "ismain"
152 and elabel = match List.assoc_opt "elabel" params with
153 | Some (G.List ["Multiedge", mul]) ->
154 Multi_edge
155 (match mul with
156 | G.String "Kint" -> Kint
157 | G.String "Kstring" -> Kstring
158 | G.List ["Kfields", G.List ll] ->
159 Kfields
160 (List.map
161 (function
162 | _, G.List l ->
163 List.map (function _,G.String f -> f
164 | _ -> raise Error) l
165 | _ -> raise Error) ll)
166 | _ -> raise Error)
167 | Some (G.String "Hiddenedge") -> Hidden_edge
168 | Some (G.List ["SumCase", G.Int i]) -> SumCase i
169 | Some (G.List ["Field", G.List fld]) ->
170 Field (r_string fld "field", r_int fld "index")
171 | Some (G.List ["Dead", G.Int i]) -> Dead i
172 | _ -> raise Error
173 in
174 { sch with edges = { src = source;
175 dst = target;
176 primary = ismain;
177 lbl = elabel } :: sch.edges }
178 | _ -> raise Error)
179 sch
180 elts
181 in
182 assert (check sch);
183 sch
184 | xx ->
185 let rec tostring = function
186 | G.String s -> "String "^s
187 | G.Int i -> string_of_int i
188 | G.Float f -> string_of_float f
189 | G.List l -> String.concat_map ~left:"[ " ~right:" ]" ";" (fun (str,x) -> str ^ " -> " ^ tostring x) l
190 in
191 Printf.eprintf "Root not found while parsing GML graph:\n%s\nParsed as\n%s\n%!"
192 s (tostring xx);
193 raise Error
194
195 let export_schema s =
196 let next_id = let x = ref 0 in fun () -> let i = !x in incr x; i in
197 assert (check s);
198 let b = FBuffer.make 1013 in
199 let pr x b = FBuffer.add b x in
200 let (@>) g f = fun x -> (f (g x)) in (* inverse composition of functions *)
201 let list f lst =
202 pr "[ "
203 @> (fun b -> List.fold_left_i (fun b x i -> (pr (Printf.sprintf "x%d " i) @> f x @> pr " ") b) b lst)
204 @> pr "]"
205 in
206 let b = pr "graph [\n" b in
207 let b,idmap =
208 StringMap.fold
209 (fun nodeid node (b,idmap) ->
210 let id = next_id() in
211 (pr (Printf.sprintf " node [ id %d nodeid \"%s\" nlabel " id nodeid) @>
212 (match node with
213 | Leaf lf ->
214 pr "[ Leaf \"" @>
215 pr (StringOf.leaf lf) @>
216 pr "\" ]"
217 | _ -> pr "\"" @> pr (StringOf.node node) @> pr "\"") @>
218 pr " ]\n")
219 b,
220 StringMap.add nodeid id idmap)
221 s.nodes
222 (b,StringMap.empty)
223 in
224 let b =
225 List.fold_left
226 (fun b e ->
227 (pr (Printf.sprintf " edge [ source %d target %d ismain %d elabel "
228 (StringMap.find e.src idmap) (StringMap.find e.dst idmap)
229 (if e.primary then 1 else 0)) @>
230 (match e.lbl with
231 | Multi_edge mk ->
232 pr "[ Multiedge " @>
233 (match mk with
234 | Kfields flds ->
235 pr "[ Kfields "
236 @> list (list (fun f -> pr (Printf.sprintf "%S" f))) flds
237 @> pr " ]"
238 | _ -> pr "\"" @> pr (StringOf.multi_key mk) @> pr "\"") @>
239 pr " ]"
240 | Hidden_edge -> pr "\"Hiddenedge\""
241 | Field (s,i) ->
242 pr (Printf.sprintf "[ Field [ field %S index %d ] ]" s i)
243 | SumCase i ->
244 pr (Printf.sprintf "[ SumCase %d ]" i)
245 | Dead i ->
246 pr (Printf.sprintf "[ Dead %d ]" i)) @>
247 pr " ]\n")
248 b)
249 b
250 s.edges
251 in
252 let b = pr "]\n" b in
253 FBuffer.contents b
254
255
256 (** Second representation of schemas
257 used for treatments of schemas (eg. calculus of diff)
258 cf. type schema for the other representation *)
259 (* note: this data structure is not well-suited for (un)serialization
260 hence, functions [to_tree] and [from_tree] are used
261 to import/export from/to the first representation *)
262
263 type tree = Tnode of string * node * (edge_label * tree) list | Tlink of string
264
265 let tnode_id = function Tnode (id,_,_) | Tlink id -> id
266
267 let filter_dead = List.filter (function (Dead _,_) -> false | _ -> true)
268
269 let rec to_tree ?(n="root") s =
270 let edges =
271 List.map
272 (fun e ->
273 if e.primary then e.lbl, to_tree ~n:e.dst s
274 else e.lbl, Tlink e.dst)
275 (List.sort (fun e1 e2 -> compare e1.lbl e2.lbl) (succ_e s n))
276 in
277 Tnode (n, node s n, edges)
278
279 let rec from_tree ?(acc={nodes=StringMap.empty; edges = []}) t = match t with
280 | Tnode (id, n, el) ->
281 List.fold_left
282 (fun acc (e,n) -> match n with
283 | Tnode (id',_,_) ->
284 let acc = from_tree ~acc n in
285 { acc with edges = { src=id; dst=id'; primary=true; lbl=e }::acc.edges }
286 | Tlink id'->
287 { acc with edges = { src=id; dst=id'; primary=false; lbl=e }::acc.edges })
288 { acc with nodes = StringMap.add id n acc.nodes }
289 el
290 | Tlink _ -> assert false
291
292 (** Utility functions on schema-trees *)
293
294 let rec fold f acc = function
295 | Tnode (_,_,el) as tn ->
296 List.fold_left (fun acc (_e,t) -> fold f acc t) (f acc tn) (filter_dead el)
297 | Tlink _ as tl -> f acc tl
298
299 let fold_edges f =
300 fold
301 (fun acc -> function
302 | Tnode (id,_,el) -> List.fold_left (fun acc (e,t) -> f acc (id,e,tnode_id t)) acc el
303 | _ -> acc)
304
305 let rec all_ids ?(acc=[]) =
306 fold (fun acc -> function Tnode (id,_,_) -> id::acc | _ -> acc) acc
307
308 let rec find_id_opt id0 = function
309 | Tnode (id,_,_el) as t when id = id0 -> Some t
310 | Tnode (_,_,el) -> List.fold_left (fun acc (_e,t) -> if Option.is_some acc then acc else find_id_opt id0 t) None el
311 | _ -> None
312
313 let find_id id0 t = Option.get (find_id_opt id0 t)
314
315 let rec map_up f = function
316 | Tnode (id,n,el) -> f (Tnode (id,n,List.map (fun (e,n) -> e, map_up f n) el))
317 | Tlink id -> f (Tlink id)
318
319 let is_parent t n n' =
320 let rec aux = function
321 | Tnode (id,_,_) when id = n' -> Some false
322 | Tnode (id,_,_) as t when id = n -> Some (Option.is_some (find_id_opt n' t))
323 | Tnode (_,_,el) -> List.fold_left (fun acc (_,t) -> match acc with None -> aux t | _ -> acc) None el
324 | _ -> None
325 in Option.get (aux t)
326
327 let out_edges = function
328 | Tnode (_,_,el) -> el
329 | _ -> []
330
331 let nice_print_path t id0 =
332 let rec edge = function
333 | Multi_edge _ -> "[]"
334 | Hidden_edge -> ""
335 | SumCase _ -> ""
336 | Field (s,_) -> "/" ^ s
337 | Dead _ -> "/<removed>" in
338 let rec aux ?parent = function
339 | Tnode (id,_n,el) when id = id0 ->
340 if parent = Some Sum then
341 Some (String.concat_map ~left:"/{" ~right:"}" "; "
342 (function (Field (s,_),_) -> s | _ -> assert false)
343 el)
344 else if parent = None then Some "/" (* print the root *)
345 else Some ""
346 | Tnode (_,parent,el) ->
347 List.fold_left
348 (fun res (e,n) -> match res with None -> Option.map ((^) (edge e)) (aux ~parent n) | _ -> res)
349 None el
350 | _ -> None
351 in Option.get (aux t)
352
353
354 (** Debug functions *)
355 let print_tree ?(color=false) t =
356 (* ported from qmltoptest/dbc.qml *)
357 let fstxlst f0 f1 f2 acc l =
358 let rec aux acc l = match l with
359 | [] -> acc
360 | [hd] -> f2 acc hd
361 | hd::tl -> aux (f1 acc hd) tl in
362 match l with
363 | [] -> acc
364 | [hd] -> f2 acc hd
365 | hd::tl -> aux (f0 acc hd) tl in
366 let mkspace s = String.init (String.length s) (fun _ -> ' ') in
367 let predge = function
368 | Multi_edge Kint -> "[int]"
369 | Multi_edge Kstring -> "[string]"
370 | Multi_edge _ -> "[*]"
371 | Hidden_edge -> "[*]"
372 | SumCase i -> Printf.sprintf "[%d]" i
373 | Field (s,i) -> Printf.sprintf "[%d-%s]" i s
374 | Dead i -> Printf.sprintf "[%d]-DEAD" i in
375 let prnode = function
376 | Multi -> "SET"
377 | Hidden -> "RECURSIVE"
378 | Sum -> "SUM"
379 | Product -> "RECORD"
380 | Leaf lf -> StringOf.leaf lf in
381 let rec aux pfx el =
382 let el = match el with e,Tnode (id,n,el) -> e,Tnode (id,n,filter_dead el) | _ -> el in
383 match el with
384 | Dead _ as edge, _ -> predge edge
385 | edge, Tnode (id,n,[]) ->
386 Printf.sprintf "%s-(%s-%s)" (predge edge) id (prnode n)
387 | edge, Tlink id ->
388 Printf.sprintf "%s-->{%s}" (predge edge) id
389 | edge, Tnode (id,n,[chld]) ->
390 let v = Printf.sprintf "%s-(%s-%s)-" (predge edge) id (prnode n) in
391 v ^ aux (pfx^(mkspace v)) chld
392 | edge, Tnode (id,n,l) ->
393 let v = Printf.sprintf "%s-(%s-%s)" (predge edge) id (prnode n) in
394 let s = mkspace v in
395 fstxlst
396 (fun acc n -> acc ^ v ^ "-+-" ^ (aux (pfx^s^" | ") n) ^ "\n" ^ pfx)
397 (fun acc n -> acc ^ s ^ " |-" ^ (aux (pfx^s^" | ") n) ^ "\n" ^ pfx)
398 (fun acc n -> acc ^ s ^ " `-" ^ (aux (pfx^s^" ") n))
399 "" l
400 in
401 let stree = match t with
402 | Tnode (_,_,[n]) -> "+-" ^ (aux " " n)
403 | Tnode (_,_,l) -> fstxlst
404 (fun acc n -> acc ^ "+-" ^ (aux "| " n) ^ "\n")
405 (fun acc n -> acc ^ "|-" ^ (aux "| " n) ^ "\n")
406 (fun acc n -> acc ^ "`-" ^ (aux " " n))
407 "" l
408 | _ -> assert false
409 in
410 if color then
411 let replace a b s = String.replace s a b in
412 ((replace "(" "(" @* replace ")" ")" @*
413 replace "{" "{" @* replace "}" "}" @*
414 replace "]" "]" @* replace "[" "[" (* '[' should be done first *))
415 stree)
416 else stree
Something went wrong with that request. Please try again.