Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

417 lines (374 sloc) 15.755 kb
(*
Copyright © 2011 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/>.
*)
(*
@author Louis Gesbert
**)
(* depends *)
module String = BaseString
module List = BaseList
(* Shorthands *)
module G = Gml_parser
(** This module imports graphs as stored by the db (cf
libqmlcompil/dbGen/schema_io.ml). The definition is close but different from
that in dbGen_common.ml (only information that is meaningful at run-time is available).
Although, now that this module is out of the BSL, it would be quite nice to factorise
at least the printer/parser between compile-time and run-time.
We have two types for the schema below: one using sets of vertices and
edges, useful when (un-)serialising; and one that looks like a tree, much
easier to manipulate.
*)
let version = 9 (* Should be the same as in libqmlcompil/dbGen/DbGen_common *)
type leaf = Leaf_int | Leaf_float | Leaf_text | Leaf_binary
type node = Multi | Hidden | Sum | Product | Leaf of leaf
type multi_key = Kint | Kstring | Kfields of string list list
type edge_label = Multi_edge of multi_key | Hidden_edge | SumCase of int | Field of string * int | Dead of int
(** Dead is for edge ids that have already been used in the past, and should therefore not be used
again if we want a consistent history *)
type edge = { src: string; dst: string; primary: bool; lbl: edge_label }
(* First representation of schemas used for (un)serialization
cf. type tree for the other representation *)
(* nodeid of Root has to be "root" *)
type schema = {
nodes: node StringMap.t;
edges: edge list;
}
module StringOf = struct
let leaf = function
| Leaf_int -> "int" | Leaf_float -> "float" | Leaf_text -> "text" | Leaf_binary -> "binary"
let node = function
| Multi -> "Multi"
| Hidden -> "Hidden"
| Sum -> "Sum"
| Product -> "Product"
| Leaf lf -> Printf.sprintf "Leaf %s" (leaf lf)
let multi_key = function
| Kint -> "Kint"
| Kstring -> "Kstring"
| Kfields flds -> Printf.sprintf "Kfields %s"
(String.concat_map ~left:"[ " ~right:" ]" "; "
(String.concat_map ~left:"[ " ~right:" ]" "; " (fun x -> x))
flds)
let edge_label = function
| Multi_edge mk -> Printf.sprintf "Multi_edge %s" (multi_key mk)
| Hidden_edge -> "Hidden_edge"
| SumCase i -> Printf.sprintf "SumCase %d" i
| Field (s,i) -> Printf.sprintf "Field %s %d" s i
| Dead i -> Printf.sprintf "Dead %d" i
end
let node s n = StringMap.find n s.nodes
let check s = List.fold_left
(* uncomplete (missing: connected, edges with distinct ids, one incoming primary, root...) *)
(fun acc -> function { src = src; dst = dst; lbl = lbl } ->
acc && StringMap.mem src s.nodes && StringMap.mem dst s.nodes &&
(match lbl with
| Multi_edge _ -> node s src = Multi
| Hidden_edge -> node s src = Hidden
| SumCase _ -> node s src = Sum
| Field _ -> node s src = Product
| Dead _ -> true))
true s.edges
let is_root n = n = 0
let succ_e s n = List.filter (fun e -> e.src = n) s.edges
let pred_e s n = List.filter (fun e -> e.dst = n) s.edges
let (@*) = InfixOperator.(@*)
let edge_num e = match e with SumCase i | Field (_,i) | Dead i -> i | _ -> assert false
exception Error
let import_schema s =
let r_int params lbl =
match List.assoc_opt lbl params with Some (G.Int i) -> i | _ -> raise Error in
let r_string params lbl =
match List.assoc_opt lbl params with Some (G.String s) -> s | _ -> raise Error in
let _pos, gml = G.parse_gml_parser_gml s in
let sch = { nodes = StringMap.empty; edges = [] }
in
(* if n < String.length s then raise Error; *)
match gml with
| G.List ["graph", G.List elts] ->
let sch, idmap = (* parse nodes *)
List.fold_left
(fun (sch, idmap) n -> match n with
| "node", G.List params ->
let id = r_int params "id"
and nodeid = r_string params "nodeid"
and nlabel = match List.assoc_opt "nlabel" params with
| Some (G.String "Multi") -> Multi
| Some (G.String "Hidden") -> Hidden
| Some (G.String "Sum") -> Sum
| Some (G.String "Product") -> Product
| Some (G.List ["Leaf", G.String "int"]) -> Leaf Leaf_int
| Some (G.List ["Leaf", G.String "float"]) -> Leaf Leaf_float
| Some (G.List ["Leaf", G.String "text"]) -> Leaf Leaf_text
| Some (G.List ["Leaf", G.String "binary"]) -> Leaf Leaf_binary
| _ -> raise Error
in
{ sch with nodes = StringMap.add nodeid nlabel sch.nodes },
IntMap.add id nodeid idmap
| "edge", _ -> sch, idmap
| _ -> raise Error)
(sch, IntMap.empty)
elts
in
let sch = (* parse edges *)
List.fold_left
(fun sch n -> match n with
| "node", _ -> sch
| "edge", G.List params ->
let source = IntMap.find (r_int params "source") idmap
and target = IntMap.find (r_int params "target") idmap
and ismain = 0 <> r_int params "ismain"
and elabel = match List.assoc_opt "elabel" params with
| Some (G.List ["Multiedge", mul]) ->
Multi_edge
(match mul with
| G.String "Kint" -> Kint
| G.String "Kstring" -> Kstring
| G.List ["Kfields", G.List ll] ->
Kfields
(List.map
(function
| _, G.List l ->
List.map (function _,G.String f -> f
| _ -> raise Error) l
| _ -> raise Error) ll)
| _ -> raise Error)
| Some (G.String "Hiddenedge") -> Hidden_edge
| Some (G.List ["SumCase", G.Int i]) -> SumCase i
| Some (G.List ["Field", G.List fld]) ->
Field (r_string fld "field", r_int fld "index")
| Some (G.List ["Dead", G.Int i]) -> Dead i
| _ -> raise Error
in
{ sch with edges = { src = source;
dst = target;
primary = ismain;
lbl = elabel } :: sch.edges }
| _ -> raise Error)
sch
elts
in
assert (check sch);
sch
| xx ->
let rec tostring = function
| G.String s -> "String "^s
| G.Int i -> string_of_int i
| G.Float f -> string_of_float f
| G.List l -> String.concat_map ~left:"[ " ~right:" ]" ";" (fun (str,x) -> str ^ " -> " ^ tostring x) l
in
Printf.eprintf "Root not found while parsing GML graph:\n%s\nParsed as\n%s\n%!"
s (tostring xx);
raise Error
let export_schema s =
let next_id = let x = ref 0 in fun () -> let i = !x in incr x; i in
assert (check s);
let b = FBuffer.make 1013 in
let pr x b = FBuffer.add b x in
let (@>) g f = fun x -> (f (g x)) in (* inverse composition of functions *)
let list f lst =
pr "[ "
@> (fun b -> List.fold_left_i (fun b x i -> (pr (Printf.sprintf "x%d " i) @> f x @> pr " ") b) b lst)
@> pr "]"
in
let b = pr "graph [\n" b in
let b,idmap =
StringMap.fold
(fun nodeid node (b,idmap) ->
let id = next_id() in
(pr (Printf.sprintf " node [ id %d nodeid \"%s\" nlabel " id nodeid) @>
(match node with
| Leaf lf ->
pr "[ Leaf \"" @>
pr (StringOf.leaf lf) @>
pr "\" ]"
| _ -> pr "\"" @> pr (StringOf.node node) @> pr "\"") @>
pr " ]\n")
b,
StringMap.add nodeid id idmap)
s.nodes
(b,StringMap.empty)
in
let b =
List.fold_left
(fun b e ->
(pr (Printf.sprintf " edge [ source %d target %d ismain %d elabel "
(StringMap.find e.src idmap) (StringMap.find e.dst idmap)
(if e.primary then 1 else 0)) @>
(match e.lbl with
| Multi_edge mk ->
pr "[ Multiedge " @>
(match mk with
| Kfields flds ->
pr "[ Kfields "
@> list (list (fun f -> pr (Printf.sprintf "%S" f))) flds
@> pr " ]"
| _ -> pr "\"" @> pr (StringOf.multi_key mk) @> pr "\"") @>
pr " ]"
| Hidden_edge -> pr "\"Hiddenedge\""
| Field (s,i) ->
pr (Printf.sprintf "[ Field [ field %S index %d ] ]" s i)
| SumCase i ->
pr (Printf.sprintf "[ SumCase %d ]" i)
| Dead i ->
pr (Printf.sprintf "[ Dead %d ]" i)) @>
pr " ]\n")
b)
b
s.edges
in
let b = pr "]\n" b in
FBuffer.contents b
(** Second representation of schemas
used for treatments of schemas (eg. calculus of diff)
cf. type schema for the other representation *)
(* note: this data structure is not well-suited for (un)serialization
hence, functions [to_tree] and [from_tree] are used
to import/export from/to the first representation *)
type tree = Tnode of string * node * (edge_label * tree) list | Tlink of string
let tnode_id = function Tnode (id,_,_) | Tlink id -> id
let filter_dead = List.filter (function (Dead _,_) -> false | _ -> true)
let rec to_tree ?(n="root") s =
let edges =
List.map
(fun e ->
if e.primary then e.lbl, to_tree ~n:e.dst s
else e.lbl, Tlink e.dst)
(List.sort (fun e1 e2 -> compare e1.lbl e2.lbl) (succ_e s n))
in
Tnode (n, node s n, edges)
let rec from_tree ?(acc={nodes=StringMap.empty; edges = []}) t = match t with
| Tnode (id, n, el) ->
List.fold_left
(fun acc (e,n) -> match n with
| Tnode (id',_,_) ->
let acc = from_tree ~acc n in
{ acc with edges = { src=id; dst=id'; primary=true; lbl=e }::acc.edges }
| Tlink id'->
{ acc with edges = { src=id; dst=id'; primary=false; lbl=e }::acc.edges })
{ acc with nodes = StringMap.add id n acc.nodes }
el
| Tlink _ -> assert false
(** Utility functions on schema-trees *)
let rec fold f acc = function
| Tnode (_,_,el) as tn ->
List.fold_left (fun acc (_e,t) -> fold f acc t) (f acc tn) (filter_dead el)
| Tlink _ as tl -> f acc tl
let fold_edges f =
fold
(fun acc -> function
| Tnode (id,_,el) -> List.fold_left (fun acc (e,t) -> f acc (id,e,tnode_id t)) acc el
| _ -> acc)
let rec all_ids ?(acc=[]) =
fold (fun acc -> function Tnode (id,_,_) -> id::acc | _ -> acc) acc
let rec find_id_opt id0 = function
| Tnode (id,_,_el) as t when id = id0 -> Some t
| Tnode (_,_,el) -> List.fold_left (fun acc (_e,t) -> if Option.is_some acc then acc else find_id_opt id0 t) None el
| _ -> None
let find_id id0 t = Option.get (find_id_opt id0 t)
let rec map_up f = function
| Tnode (id,n,el) -> f (Tnode (id,n,List.map (fun (e,n) -> e, map_up f n) el))
| Tlink id -> f (Tlink id)
let is_parent t n n' =
let rec aux = function
| Tnode (id,_,_) when id = n' -> Some false
| Tnode (id,_,_) as t when id = n -> Some (Option.is_some (find_id_opt n' t))
| Tnode (_,_,el) -> List.fold_left (fun acc (_,t) -> match acc with None -> aux t | _ -> acc) None el
| _ -> None
in Option.get (aux t)
let out_edges = function
| Tnode (_,_,el) -> el
| _ -> []
let nice_print_path t id0 =
let rec edge = function
| Multi_edge _ -> "[]"
| Hidden_edge -> ""
| SumCase _ -> ""
| Field (s,_) -> "/" ^ s
| Dead _ -> "/<removed>" in
let rec aux ?parent = function
| Tnode (id,_n,el) when id = id0 ->
if parent = Some Sum then
Some (String.concat_map ~left:"/{" ~right:"}" "; "
(function (Field (s,_),_) -> s | _ -> assert false)
el)
else if parent = None then Some "/" (* print the root *)
else Some ""
| Tnode (_,parent,el) ->
List.fold_left
(fun res (e,n) -> match res with None -> Option.map ((^) (edge e)) (aux ~parent n) | _ -> res)
None el
| _ -> None
in Option.get (aux t)
(** Debug functions *)
let print_tree ?(color=false) t =
(* ported from qmltoptest/dbc.qml *)
let fstxlst f0 f1 f2 acc l =
let rec aux acc l = match l with
| [] -> acc
| [hd] -> f2 acc hd
| hd::tl -> aux (f1 acc hd) tl in
match l with
| [] -> acc
| [hd] -> f2 acc hd
| hd::tl -> aux (f0 acc hd) tl in
let mkspace s = String.init (String.length s) (fun _ -> ' ') in
let predge = function
| Multi_edge Kint -> "[int]"
| Multi_edge Kstring -> "[string]"
| Multi_edge _ -> "[*]"
| Hidden_edge -> "[*]"
| SumCase i -> Printf.sprintf "[%d]" i
| Field (s,i) -> Printf.sprintf "[%d-%s]" i s
| Dead i -> Printf.sprintf "[%d]-DEAD" i in
let prnode = function
| Multi -> "SET"
| Hidden -> "RECURSIVE"
| Sum -> "SUM"
| Product -> "RECORD"
| Leaf lf -> StringOf.leaf lf in
let rec aux pfx el =
let el = match el with e,Tnode (id,n,el) -> e,Tnode (id,n,filter_dead el) | _ -> el in
match el with
| Dead _ as edge, _ -> predge edge
| edge, Tnode (id,n,[]) ->
Printf.sprintf "%s-(%s-%s)" (predge edge) id (prnode n)
| edge, Tlink id ->
Printf.sprintf "%s-->{%s}" (predge edge) id
| edge, Tnode (id,n,[chld]) ->
let v = Printf.sprintf "%s-(%s-%s)-" (predge edge) id (prnode n) in
v ^ aux (pfx^(mkspace v)) chld
| edge, Tnode (id,n,l) ->
let v = Printf.sprintf "%s-(%s-%s)" (predge edge) id (prnode n) in
let s = mkspace v in
fstxlst
(fun acc n -> acc ^ v ^ "-+-" ^ (aux (pfx^s^" | ") n) ^ "\n" ^ pfx)
(fun acc n -> acc ^ s ^ " |-" ^ (aux (pfx^s^" | ") n) ^ "\n" ^ pfx)
(fun acc n -> acc ^ s ^ " `-" ^ (aux (pfx^s^" ") n))
"" l
in
let stree = match t with
| Tnode (_,_,[n]) -> "+-" ^ (aux " " n)
| Tnode (_,_,l) -> fstxlst
(fun acc n -> acc ^ "+-" ^ (aux "| " n) ^ "\n")
(fun acc n -> acc ^ "|-" ^ (aux "| " n) ^ "\n")
(fun acc n -> acc ^ "`-" ^ (aux " " n))
"" l
| _ -> assert false
in
if color then
let replace a b s = String.replace s a b in
((replace "(" "(" @* replace ")" ")" @*
replace "{" "{" @* replace "}" "}" @*
replace "]" "]" @* replace "[" "[" (* '[' should be done first *))
stree)
else stree
Jump to Line
Something went wrong with that request. Please try again.