Source file dot.ml

(*********************************************************************************)
(*                OCaml-RDF                                                      *)
(*                                                                               *)
(*    Copyright (C) 2012-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program 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 General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

open Term;;

module Irimap = Iri.Map
module SSet = Types.SSet;;

let apply_namespaces namespaces iri =
  let len_iri = String.length iri in
  let rec iter = function
    [] -> ("",iri)
  | (pref,ns) :: q ->
      let len = String.length ns in
      if len <= len_iri && String.sub iri 0 len = ns then
        (pref, String.sub iri len (len_iri - len))
      else
        iter q
  in
  iter namespaces
;;

let build_namespaces ?(namespaces=[]) g =
  let l = (g.Graph.namespaces ()) @ namespaces in
  let f (map, set) (iri, pref) =
    try
      ignore(Irimap.find iri map);
      (* this iri already has a prefix, ignore this association *)
      (map, set)
    with Not_found ->
        if SSet.mem pref set then
          failwith (Printf.sprintf "%S is already the prefix of another namespace." pref)
        else
          (
           let map = Irimap.add iri pref map in
           let set = SSet.add pref set in
           (map, set)
          )
  in
  let (map, _) = List.fold_left f (Irimap.empty, SSet.empty) l in
  Irimap.fold (fun iri s acc -> (s, Iri.to_string iri) :: acc) map []
;;

let string_of_literal lit =
  let s =
    (lit.lit_value) ^
      (match lit.lit_language with
         None -> ""
       | Some l -> "@" ^ l
      ) ^
      (match lit.lit_type with
         None -> ""
       | Some t -> "^^<" ^ (Iri.to_string t) ^ ">"
      )
  in
  Printf.sprintf "\"%s\"" (Utf8.utf8_backslash_quotes s)

let dot_of_graph ?namespaces ?href ?iri g =
  let namespaces = build_namespaces ?namespaces g in
  let b = Buffer.create 256 in
  Buffer.add_string b "digraph g {\nrankdir=LR;\nfontsize=10;\n";
  let triples =
    match iri with
      None -> g.Graph.find ()
    | Some iri ->
        let node = Term.Iri iri in
        let to_iri = g.Graph.find ~sub: node () in
        let from_iri = g.Graph.find ~obj: node () in
        to_iri @ from_iri
  in
  let label node =
    match node with
      Iri iri ->
         let iri = Iri.to_string iri in
         let (pref,s) = apply_namespaces namespaces iri in
         let s =
          begin
            match pref with
              "" -> s
            | _ -> pref ^ ":" ^ s
          end
        in
        Printf.sprintf "%S" s
    | Literal lit -> string_of_literal lit
    | Blank_ _ | Blank -> "\"\""
  in
  let id node =
    let s =
      match node with
        Iri iri -> Iri.to_string iri
      | Blank_ id -> "b"^(string_of_blank_id id)
      | Literal lit ->
          lit.lit_value
            ^ "^" ^ (match lit.lit_language with None -> "" | Some s -> s)
            ^ "@" ^ (match lit.lit_type with None -> "" | Some iri -> Iri.to_string iri)
      | Blank -> assert false
    in
    "N" ^ (Digest.to_hex (Digest.string s))
  in
  let f set (sub, pred, obj) =
    Printf.bprintf b "%s -> %s [label=%s];\n" (id sub) (id obj) (label (Iri pred));
    Term.TSet.add sub (Term.TSet.add obj set)
  in
  let set = List.fold_left f Term.TSet.empty triples in
  let f_node node =
    Printf.bprintf b "%s [ label=%s %s];\n" (id node) (label node)
      (match href with
         None -> ""
       | Some f ->
           match f node with
             None -> ""
           | Some s -> ", href=\""^s^"\""
      )
  in
  Term.TSet.iter f_node set;
  Buffer.add_string b "}\n";
  Buffer.contents b
;;

let dot_of_iri ?namespaces ?href g iri = dot_of_graph ?namespaces ?href ~iri g;;
let dot_of_graph ?namespaces ?href g = dot_of_graph ?namespaces ?href g;;