package b0

  1. Overview
  2. Docs
Software construction and deployment kit

Install 

dune-project
 Dependency

erratique.ch Readme Changelog ISC; BSD-2-Clause License Edit opam file Versions (2)

Authors

  1. T
    The b0 programmers

Maintainers

  1. Daniel Bünzli

Sources

b0-0.0.6.tbz
sha512=e9aa779e66c08fc763019f16d4706f465d16c05d6400b58fbd0313317ef33ddea51952e2b058db28e65f7ddb7012f328c8bf02d8f1da17bb543348541a2587f0

doc/src/b0.std/b0_dot.ml.html

Source file b0_dot.ml

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
(*---------------------------------------------------------------------------
   Copyright (c) 2016 The b0 programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

(* Generator *)

type gen = { edgeop : string; b : Buffer.t }
type k = gen -> unit

let addc c g = Buffer.add_char g.b c
let adds s g = Buffer.add_string g.b s
let adds_id s g = (* escape quotes *)
  let len = String.length s in
  let max_idx = len - 1 in
  let flush b start i =
    if start < len then Buffer.add_substring b s start (i - start);
  in
  let rec loop start i =
    if i > max_idx then flush g.b start i else
    match String.get s i with
    | '\"' -> flush g.b start i; adds "\"" g; loop (i + 1) (i + 1)
    | c -> loop start (i + 1)
  in
  addc '"' g; loop 0 0; addc '"' g

let adds_html s g = addc '<' g; adds s g; addc '>' g

(* Generation sequences. *)

type 'a seq = gen -> unit
let empty g = ()
let ( ++ ) s s' g = s g; s' g; ()

(* Graph *)

type id = string
type st
type att
type t = (gen -> unit) * string

let alist a g = match a with None -> () | Some a -> addc '[' g; a g; addc ']' g

let edge ?atts:a id id' g =
  adds_id id g; adds g.edgeop g; adds_id id' g; alist a g; adds ";\n" g

let node ?atts:a id g = adds_id id g; alist a g; adds ";\n" g

let atts k atts g =
  let kind = match k with
  | `Graph -> "graph "
  | `Node -> "node "
  | `Edge -> "edge "
  in
  adds kind g; alist (Some atts) g; adds ";\n" g

let att a v g = adds_id a g; addc '=' g; adds_id v g
let att_html a v g = adds_id a g; addc '=' g; adds_html v g

let label = att "label"
let color = att "color"
let subgraph ?id sts g =
  let id = match id with None -> empty | Some id -> adds_id id in
  adds "subgraph" g; id g; adds "{\n" g; sts g; adds "}\n" g

let graph ?id ?(strict = false) g sts =
  let strict = if strict then adds "strict " else empty in
  let kind, edgeop = match g with
  | `Graph -> adds "graph ", "--"
  | `Digraph -> adds "digraph ", "->"
  in
  let id = match id with None -> empty | Some id -> adds_id id ++ addc ' ' in
  (fun g -> strict g; kind g; id g; adds "{\n" g; sts g; adds "}\n" g),
  edgeop

(* Output *)

let buffer_add b (g, edgeop) = g { edgeop; b }

let kbuf k g =
  let b = Buffer.create 65525 in
  buffer_add b g;
  k b

let to_string g = kbuf Buffer.contents g
let output oc g = kbuf (fun b -> Buffer.output_buffer oc b) g