Skip to content
This repository
tag: v1161
Fetching contributors…

Cannot retrieve contributors at this time

file 416 lines (374 sloc) 15.755 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416
(*
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
Something went wrong with that request. Please try again.