bundles/menhirLib/menhir-20120123/src/dot.ml

   1 (**************************************************************************)
   2 (*                                                                        *)
   3 (*  Menhir                                                                *)
   4 (*                                                                        *)
   5 (*  François Pottier, INRIA Rocquencourt                                  *)
   6 (*  Yann Régis-Gianas, PPS, Université Paris Diderot                      *)
   7 (*                                                                        *)
   8 (*  Copyright 2005-2008 Institut National de Recherche en Informatique    *)
   9 (*  et en Automatique. All rights reserved. This file is distributed      *)
  10 (*  under the terms of the Q Public License version 1.0, with the change  *)
  11 (*  described in file LICENSE.                                            *)
  12 (*                                                                        *)
  13 (**************************************************************************)
  14
  15 open Printf
  16
  17 (* ------------------------------------------------------------------------- *)
  18
  19 (* Type definitions. *)
  20
  21 type size =
  22     float * float (* in inches *)
  23
  24 type orientation =
  25   | Portrait
  26   | Landscape
  27
  28 type rankdir =
  29   | LeftToRight
  30   | TopToBottom
  31
  32 type ratio =
  33   | Compress
  34   | Fill
  35   | Auto
  36
  37 type style =
  38
  39     (* Both nodes and edges. *)
  40
  41   | Solid
  42   | Dashed
  43   | Dotted
  44   | Bold
  45   | Invisible
  46
  47     (* Nodes only. *)
  48
  49   | Filled
  50   | Diagonals
  51   | Rounded
  52
  53 (* ------------------------------------------------------------------------- *)
  54
  55 (* Basic printers. *)
  56
  57 let print_style = function
  58   | None ->
  59       ""
  60   | Some style ->
  61       let style =
  62         match style with
  63         | Solid ->
  64             "solid"
  65         | Dashed ->
  66             "dashed"
  67         | Dotted ->
  68             "dotted"
  69         | Bold ->
  70             "bold"
  71         | Invisible ->
  72             "invis"
  73         | Filled ->
  74             "filled"
  75         | Diagonals ->
  76             "diagonals"
  77         | Rounded ->
  78             "rounded"
  79       in
  80       sprintf ", style = %s" style
  81
  82 (* ------------------------------------------------------------------------- *)
  83
  84 (* The graph printer. *)
  85
  86 module Print (G : sig
  87
  88   type vertex
  89
  90   val name: vertex -> string
  91
  92   val successors: (?style:style -> label:string -> vertex -> unit) -> vertex -> unit
  93
  94   val iter: (?style:style -> label:string -> vertex -> unit) -> unit
  95
  96 end) = struct
  97
  98   let print
  99       ?(directed = true)
 100       ?size
 101       ?(orientation = Landscape)
 102       ?(rankdir = LeftToRight)
 103       ?(ratio = Compress)
 104       (f : out_channel)
 105       =
 106
 107     fprintf f "%s G {\n" (if directed then "digraph" else "graph");
 108     Option.iter (fun (hsize, vsize) ->
 109       fprintf f "size=\"%f, %f\";\n" hsize vsize
 110     ) size;
 111     begin match orientation with
 112       | Portrait ->
 113           fprintf f "orientation = portrait;\n"
 114       | Landscape ->
 115           fprintf f "orientation = landscape;\n"
 116     end;
 117     begin match rankdir with
 118       | LeftToRight ->
 119           fprintf f "rankdir = LR;\n"
 120       | TopToBottom ->
 121           fprintf f "rankdir = TB;\n"
 122     end;
 123     begin match ratio with
 124       | Compress ->
 125           fprintf f "ratio = compress;\n"
 126       | Fill ->
 127           fprintf f "ratio = fill;\n"
 128       | Auto ->
 129           fprintf f "ratio = auto;\n"
 130     end;
 131
 132     G.iter (fun ?style ~label vertex ->
 133       fprintf f "%s [ label=\"%s\"%s ] ;\n"
 134         (G.name vertex)
 135         label
 136         (print_style style)
 137     );
 138
 139     G.iter (fun ?style ~label source ->
 140       G.successors (fun ?style ~label destination ->
 141         fprintf f "%s %s %s [ label=\"%s\"%s ] ;\n"
 142           (G.name source)
 143           (if directed then "->" else "--")
 144           (G.name destination)
 145           label
 146           (print_style style)
 147       ) source
 148     );
 149
 150     fprintf f "\n}\n"
 151
 152 end
 153