diff --git a/core/CCKTree.ml b/core/CCKTree.ml index e18c89c7..f19fd14d 100644 --- a/core/CCKTree.ml +++ b/core/CCKTree.ml @@ -33,6 +33,7 @@ type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a printer = Buffer.t -> 'a -> unit +type 'a formatter = Format.formatter -> 'a -> unit type +'a t = unit -> [`Nil | `Node of 'a * 'a t list] @@ -132,7 +133,7 @@ module FQ = struct hd : 'a list; tl : 'a list; } - + exception Empty (* invariant: if hd=[], then tl=[] *) @@ -220,24 +221,24 @@ module Dot = struct | `Id n :: l' -> n, List.rev_append acc l' | x :: l' -> _find_id (x::acc) l' - let _pp_attr buf attr = match attr with - | `Color c -> Printf.bprintf buf "color=%s" c - | `Shape s -> Printf.bprintf buf "shape=%s" s - | `Weight w -> Printf.bprintf buf "weight=%d" w - | `Style s -> Printf.bprintf buf "style=%s" s - | `Label l -> Printf.bprintf buf "label=\"%s\"" l - | `Other (name, value) -> Printf.bprintf buf "%s=\"%s\"" name value + let _pp_attr fmt attr = match attr with + | `Color c -> Format.fprintf fmt "color=%s" c + | `Shape s -> Format.fprintf fmt "shape=%s" s + | `Weight w -> Format.fprintf fmt "weight=%d" w + | `Style s -> Format.fprintf fmt "style=%s" s + | `Label l -> Format.fprintf fmt "label=\"%s\"" l + | `Other (name, value) -> Format.fprintf fmt "%s=\"%s\"" name value | `Id _ -> () (* should not be here *) - let rec _pp_attrs buf l = match l with + let rec _pp_attrs fmt l = match l with | [] -> () - | [x] -> _pp_attr buf x + | [x] -> _pp_attr fmt x | x::l' -> - _pp_attr buf x; - Buffer.add_char buf ','; - _pp_attrs buf l' + _pp_attr fmt x; + Format.pp_print_char fmt ','; + _pp_attrs fmt l' - let pp buf (name,l) = + let print fmt (name,l) = (* nodes already printed *) let tbl = Hashtbl.create 32 in (* fresh name generator *) @@ -267,11 +268,11 @@ module Dot = struct let name, attrs = get_name x in begin match parent with | None -> () - | Some n -> Printf.bprintf buf " %s -> %s;\n" n name + | Some n -> Format.fprintf fmt " %s -> %s;@," n name end; if not (Hashtbl.mem tbl name) then ( Hashtbl.add tbl name (); - Printf.bprintf buf " %s [%a];\n" name _pp_attrs attrs; + Format.fprintf fmt "@[%s [%a];@]@," name _pp_attrs attrs; List.fold_left (fun q y -> FQ.push q (Some name, y)) q l ) else q @@ -282,11 +283,16 @@ module Dot = struct FQ.empty l in (* preamble *) - Printf.bprintf buf "digraph %s {\n" name; + Format.fprintf fmt "@[digraph %s {@," name; aux q; - Printf.bprintf buf "}\n"; + Format.fprintf fmt "}@]@."; () + let pp buf t = + let fmt = Format.formatter_of_buffer buf in + print fmt t; + Format.pp_print_flush fmt () + let pp_single name buf t = pp buf (singleton ~name t) end diff --git a/core/CCKTree.mli b/core/CCKTree.mli index b34183a1..1235ebc0 100644 --- a/core/CCKTree.mli +++ b/core/CCKTree.mli @@ -33,6 +33,7 @@ type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a printer = Buffer.t -> 'a -> unit +type 'a formatter = Format.formatter -> 'a -> unit (** {2 Basics} *) @@ -123,5 +124,7 @@ module Dot : sig (** Print the graph in DOT *) val pp_single : string -> attribute list t printer + + val print : graph formatter end diff --git a/misc/printBox.mli b/misc/printBox.mli index 30cb3d4f..99e91ee5 100644 --- a/misc/printBox.mli +++ b/misc/printBox.mli @@ -147,6 +147,8 @@ val vpad : int -> Box.t -> Box.t val hpad : int -> Box.t -> Box.t (** Pad horizontally *) +(* TODO: right-align/left-align *) + val grid : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t array array -> Box.t (** Grid of boxes (no frame between boxes). The matrix is indexed