ccwl: Support graphviz HTML strings.

* ccwl/graphviz.scm (<html-string>): New type.
(escape-id): Delete function.
(serialize): New function.
(graph->dot): Use serialize instead of escape-id.
* tests/graphviz.scm: New file.
("serialize HTML strings correctly"): New test case.
* Makefile.am (SCM_TESTS): Register it.

3 files changed, 80 insertions, 18 deletions

diff --git a/Makefile.am b/Makefile.am
index 9250230..218ccc7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -75,7 +75,7 @@ bin_SCRIPTS = scripts/ccwl
 
 SOURCES = ccwl/ccwl.scm ccwl/cwl.scm ccwl/graphviz.scm ccwl/yaml.scm ccwl/utils.scm
 TEST_EXTENSIONS = .scm
-SCM_TESTS = tests/ccwl.scm tests/utils.scm tests/yaml.scm
+SCM_TESTS = tests/ccwl.scm tests/graphviz.scm tests/utils.scm tests/yaml.scm
 TESTS = $(SCM_TESTS)
 
 SCM_LOG_DRIVER =		\
diff --git a/ccwl/graphviz.scm b/ccwl/graphviz.scm
index 7093bdb..fbef971 100644
--- a/ccwl/graphviz.scm
+++ b/ccwl/graphviz.scm
@@ -62,6 +62,11 @@ language."
   "Construct <graph-node> object."
   (make-graph-node name properties))
 
+(define-immutable-record-type <html-string>
+  (html-string str)
+  html-string?
+  (str html-string-underlying))
+
 (define (workflow->graph workflow)
   "Convert WORKFLOW, a <workflow> object, to a <graph> object."
   (graph 'workflow
@@ -112,18 +117,27 @@ language."
                                                                (style . "filled"))))
                                                (workflow-outputs workflow))))))
 
-(define (escape-id id)
-  "Escape string ID if necessary according to graphviz dot syntax."
-  (let ((id (if (symbol? id)
-                (symbol->string id)
-                id)))
-    (if (string-every (char-set-union (char-set-intersection char-set:letter+digit
-                                                             char-set:ascii)
-                                      (char-set #\_))
-                      id)
-        id
-        (call-with-output-string
-          (cut write id <>)))))
+(define (serialize object)
+  "Serialize OBJECT according to graphviz dot syntax. OBJECT may a
+symbol, a string, or a <html-string> object."
+  (let ((str (cond
+              ((symbol? object) (symbol->string object))
+              ((string? object) object)
+              ((html-string? object) (html-string-underlying object))
+              (else (error "Unknown object type to serialize to graphviz dot:" object)))))
+    (cond
+     ;; Surround HTML strings in <>, and don't escape.
+     ((html-string? object)
+      (format "<~a>" str))
+     ;; Don't escape safe strings.
+     ((string-every (char-set-union (char-set-intersection char-set:letter+digit
+                                                           char-set:ascii)
+                                    (char-set #\_))
+                    str)
+      str)
+     ;; Escape strings with unsafe characters.
+     (else (call-with-output-string
+             (cut write str <>))))))
 
 (define* (graph->dot graph #:optional (port (current-output-port)) (level 0))
   "Render GRAPH, a <graph> object, in the graphviz dot syntax to
@@ -136,16 +150,16 @@ PORT."
   (for-each (match-lambda
               ((key . value)
                (indent-level port (1+ level))
-               (display (format "~a=~a;~%" key (escape-id value)) port)))
+               (display (format "~a=~a;~%" key (serialize value)) port)))
             (graph-properties graph))
   (for-each (lambda (node)
               (indent-level port (1+ level))
-              (display (escape-id (graph-node-name node)) port)
+              (display (serialize (graph-node-name node)) port)
               (unless (null? (graph-node-properties node))
                 (display (format " [~a]"
                                  (string-join (map (match-lambda
                                                      ((key . value)
-                                                      (format "~a=~a" key (escape-id value))))
+                                                      (format "~a=~a" key (serialize value))))
                                                    (graph-node-properties node))
                                               ", "))
                          port))
@@ -155,8 +169,8 @@ PORT."
               ((from . to)
                (indent-level port (1+ level))
                (display (format "~a -> ~a;~%"
-                                (escape-id from)
-                                (escape-id to))
+                                (serialize from)
+                                (serialize to))
                         port)))
             (graph-edges graph))
   (for-each (lambda (subgraph)
diff --git a/tests/graphviz.scm b/tests/graphviz.scm
new file mode 100644
index 0000000..5853616
--- /dev/null
+++ b/tests/graphviz.scm
@@ -0,0 +1,48 @@
+;;; ccwl --- Concise Common Workflow Language
+;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of ccwl.
+;;;
+;;; ccwl is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; ccwl 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 ccwl.  If not, see <https://www.gnu.org/licenses/>.
+
+(use-modules (srfi srfi-64))
+
+(define graph->dot
+  (@@ (ccwl graphviz) graph->dot))
+
+(define graph
+  (@@ (ccwl graphviz) graph))
+
+(define graph-node
+  (@@ (ccwl graphviz) graph-node))
+
+(define html-string
+  (@@ (ccwl graphviz) html-string))
+
+(test-begin "graphviz")
+
+(test-equal "serialize HTML strings correctly"
+  "digraph foo {
+  bar [label=<<table><tr><td>bar</td></tr></table>>];
+}
+"
+  (call-with-output-string
+    (lambda (port)
+      (graph->dot
+       (graph 'foo
+              #:nodes (list (graph-node 'bar
+                                        `((label . ,(html-string "<table><tr><td>bar</td></tr></table>"))))))
+       port))))
+
+(test-end "graphviz")