ccwl: Support graphviz node ports.

* ccwl/graphviz.scm (<graph-port>): New type.
(serialize): Support <graph-port> objects.
* tests/graphviz.scm (graph-port): New function.
("serialize ports correctly"): New test case.

2 files changed, 26 insertions, 1 deletions

diff --git a/ccwl/graphviz.scm b/ccwl/graphviz.scm
index a505530..3aa3f2a 100644
--- a/ccwl/graphviz.scm
+++ b/ccwl/graphviz.scm
@@ -63,6 +63,12 @@ language."
   "Construct <graph-node> object."
   (make-graph-node name properties))
 
+(define-immutable-record-type <graph-port>
+  (graph-port node port)
+  graph-port?
+  (node graph-port-node)
+  (port graph-port-name))
+
 (define-immutable-record-type <html-string>
   (html-string str)
   html-string?
@@ -120,10 +126,14 @@ language."
 
 (define (serialize object)
   "Serialize OBJECT according to graphviz dot syntax. OBJECT may a
-symbol, a string, or a <html-string> object."
+symbol, a string, a <graph-port> object, or a <html-string> object."
   (cond
    ((symbol? object)
     (serialize (symbol->string object)))
+   ((graph-port? object)
+    (string-append (serialize (graph-port-node object))
+                   ":"
+                   (serialize (graph-port-name object))))
    ;; Surround HTML strings in <>, and don't escape.
    ((html-string? object)
     (format "<~a>" (html-string-underlying object)))
diff --git a/tests/graphviz.scm b/tests/graphviz.scm
index bb99edc..b61cc61 100644
--- a/tests/graphviz.scm
+++ b/tests/graphviz.scm
@@ -27,6 +27,9 @@
 (define graph-node
   (@@ (ccwl graphviz) graph-node))
 
+(define graph-port
+  (@@ (ccwl graphviz) graph-port))
+
 (define html-string
   (@@ (ccwl graphviz) html-string))
 
@@ -58,4 +61,16 @@
                                         `((label . "foo\\lbar")))))
        port))))
 
+(test-equal "serialize ports correctly"
+  "digraph foo {
+  foo:p1 -> bar:p2;
+}
+"
+  (call-with-output-string
+    (lambda (port)
+      (graph->dot
+       (graph 'foo
+              #:edges `((,(graph-port "foo" "p1") . ,(graph-port "bar" "p2"))))
+       port))))
+
 (test-end "graphviz")