From ec5cfa689b826f3d99badb9303f31c83f24bae5d Mon Sep 17 00:00:00 2001
From: Lassi Kortela <lassi@lassi.io>
Date: Tue, 24 Aug 2021 20:47:07 +0300
Subject: [PATCH] Add Chicken module

---
 pandoc.chicken.scm | 39 +++++++++++++++++++++
 pandoc.r5rs.scm    | 85 ++++++++++++++++++++++++++++++++++++++++++++++
 test.chicken.scm   | 11 ++++++
 3 files changed, 135 insertions(+)
 create mode 100644 pandoc.chicken.scm
 create mode 100644 pandoc.r5rs.scm
 create mode 100644 test.chicken.scm

diff --git a/pandoc.chicken.scm b/pandoc.chicken.scm
new file mode 100644
index 0000000..8f4ab6b
--- /dev/null
+++ b/pandoc.chicken.scm
@@ -0,0 +1,39 @@
+(module pandoc
+
+  (pandoc-command-line
+   pandoc-port->json
+   pandoc-port->sxml
+   pandoc-file->json
+   pandoc-file->sxml)
+
+  (import (scheme)
+          (chicken base)
+          (only (chicken io) read-byte write-byte)
+          (only (chicken port) copy-port)
+          (only (chicken process) process process-wait)
+          (rename (only (medea) read-json)
+                  (read-json json-read)))
+
+  (define (run-read-write args input-port read-output)
+    (receive (from-sub to-sub sub) (process (car args) (cdr args))
+      (copy-port input-port to-sub read-byte write-byte)
+      (close-output-port to-sub)
+      (let ((output (read-output from-sub)))
+        (receive (sub clean-exit? exit-status) (process-wait sub)
+          ;; Call `process-wait` before closing the last port to avoid
+          ;; triggering the automatic `process-wait` done by `process`
+          ;; when all ports are closed. If we relied on the implicit
+          ;; `process-wait`, we couldn't find out the exit status.
+          (close-input-port from-sub)
+          (if (and clean-exit? (eqv? 0 exit-status)) output
+              (error "Error running" args))))))
+
+  (define (call-with-binary-input-file filename proc)
+    (let ((port (open-input-file filename #:binary)))
+      (dynamic-wind (lambda () #f)
+                    (lambda () (proc port))
+                    (lambda () (close-input-port port)))))
+
+  (define pandoc-command-line (make-parameter (list "pandoc")))
+
+  (include "pandoc.r5rs.scm"))
diff --git a/pandoc.r5rs.scm b/pandoc.r5rs.scm
new file mode 100644
index 0000000..8b2f411
--- /dev/null
+++ b/pandoc.r5rs.scm
@@ -0,0 +1,85 @@
+(define (join-adjacent type? type-append list)
+  (let loop ((new-list '()) (list list))
+    (if (null? list) (reverse new-list)
+        (loop (if (and (not (null? new-list))
+                       (type? (car new-list))
+                       (type? (car list)))
+                  (cons (type-append (car new-list)
+                                     (car list))
+                        (cdr new-list))
+                  (cons (car list) new-list))
+              (cdr list)))))
+
+(define (vector-refs vec . indexes)
+  (let loop ((obj vec) (indexes indexes))
+    (if (null? indexes) obj
+        (loop (vector-ref obj (car indexes))
+              (cdr indexes)))))
+
+(define (pandoc-json->sxml json)
+  (define (convert-block-or-inline element)
+    (if (string? element) element (convert-block element)))
+  (define (convert-block block)
+    (let ((type (cdr (assq 't block))))
+      (define (contents) (cdr (assq 'c block)))
+      (define (contents-list) (vector->list (contents)))
+      (cond ((equal? type "Space")
+             " ")
+            ((equal? type "Str")
+             (contents))
+            ((equal? type "Code")
+             `(code ,@(convert-many (cdr (contents-list)))))
+            ((equal? type "Header")
+             (let* ((level (car (contents-list)))
+                    (h-tag (string->symbol
+                            (string-append "h" (number->string level)))))
+               `(,h-tag ,@(convert-many (vector->list
+                                         (list-ref (contents-list) 2))))))
+            ((equal? type "Plain")
+             `(span ,@(convert-many (contents-list))))
+            ((equal? type "Para")
+             `(p ,@(convert-many (contents-list))))
+            ((equal? type "SoftBreak")
+             "\n")
+            ((equal? type "Table")
+             (let ((headings (vector-refs (contents) 3 1 0 1)))
+               `(table
+                 (tr
+                  ,@(map (lambda (cell)
+                           (let ((elements (vector->list
+                                            (vector-refs cell 4))))
+                             `(th ,@(map convert-block-or-inline elements))))
+                         (vector->list headings)))
+                 ,@(map (lambda (row)
+                          `(tr ,@(map (lambda (cell)
+                                        (let ((elements
+                                               (vector->list
+                                                (vector-refs cell 4))))
+                                          `(td ,@(map convert-block-or-inline
+                                                      elements))))
+                                      (vector->list (vector-refs row 1)))))
+                        (vector->list (vector-refs (contents) 4 0 3))))))
+            (else
+             (error "Unknown type" type)))))
+  (define (convert-many elements)
+    (join-adjacent string? string-append
+                   (map convert-block-or-inline elements)))
+  (convert-many (vector->list (cdr (assq 'blocks json)))))
+
+(define (pandoc-port->json input-format input-port)
+  (run-read-write (append (pandoc-command-line)
+                          (list "--from" (symbol->string input-format)
+                                "--to" "json"))
+                  input-port
+                  json-read))
+
+(define (pandoc-port->sxml input-format input-port)
+  (pandoc-json->sxml (pandoc-port->json input-format input-port)))
+
+(define (pandoc-file->json input-format input-filename)
+  (call-with-binary-input-file
+   input-filename
+   (lambda (input-port) (pandoc-port->json input-format input-port))))
+
+(define (pandoc-file->sxml input-format input-filename)
+  (pandoc-json->sxml (pandoc-file->json input-format input-filename)))
diff --git a/test.chicken.scm b/test.chicken.scm
new file mode 100644
index 0000000..8c53cfd
--- /dev/null
+++ b/test.chicken.scm
@@ -0,0 +1,11 @@
+(load "pandoc.chicken.scm")
+(import (chicken pretty-print)
+        (only (sxml-transforms) SXML->HTML)
+        (pandoc))
+(SXML->HTML (pandoc-file->sxml 'gfm "test/CharEq.md"))
+(newline)
+(newline)
+(SXML->HTML (pandoc-file->sxml 'gfm "test/VoidValue.md"))
+(newline)
+(newline)
+(pretty-print (pandoc-file->json 'gfm "test/VoidValue.md"))