1 files changed, 109 insertions, 0 deletions

@@ -0,0 +1,109 @@
+(declare (module (jimmy emit)))
+
+(import scheme (chicken base)
+        (jimmy util)
+        (chicken format)
+        (chicken irregex)
+        (chicken string))
+
+(define-public (emit document)
+  (for-each display
+            (map format-block document)))
+
+(define-public formats
+  ;;; (type line-format block-format [line-in-block-format])
+  ;; these default to gemtext
+  '((para (line . "~A ")
+          (block . "~A~%~%"))
+    (verb (line . "~A~%")
+          (block . "```~%~A```~%~%"))
+    (link (line . "=> ~A ~A~%")
+          (block . "~A~%")
+          (inline . "~%=> ~A ~A~%")) ;TODO: have 2 args to format
+    (list (line . "* ~A~%")
+          (block . "~A~%"))
+    (quot (line . "~A ")
+          (block . "> ~A~%~%"))
+    (hdr1 (line . "# ~A~%")
+          (block . "~A~%"))
+    (hdr2 (line . "## ~A~%")
+          (block . "~A~%"))
+    (hdr3 (line . "### ~A~%")
+          (block . "~A~%"))
+    (default
+      (line . "~A")
+      (block . "~A~%~%"))))
+
+(define (string-join ss #!optional sep)
+  (if (string? ss) ss
+      (string-intersperse ss (or sep " "))))
+
+(define (char->tag char beg end)
+  (lambda (str)
+    (irregex-replace/all `(: ($ (or bos space))
+                             ,char ($ (+ (~ ,char))) ,char
+                             ($ (or space eos)))
+                         str
+                         1 beg 2 end 3)))
+
+(define-public filters
+  `((para
+     (line . ,(o (char->tag "*" "<strong>" "</strong>")
+                 (char->tag "_" "<em>" "</em>")
+                 (char->tag "`" "<code>" "</code>")
+                 string-join))
+     (block . ,(lambda (ln)
+                 (irregex-replace/all '(: bol (* " ")) ln ""))))
+    (link
+     (line . ,(lambda (ln)
+                (let ((ws (cond ((list? ln) ln)
+                                ((string? ln) (string-split ln)))))
+                  (list (car ws) (string-join (cdr ws)))))))
+    (default
+      (line . ,list)
+      (block . ,identity))))
+
+(define (get-from from type subtype)
+  (or (alist-walk from type subtype)
+      (if (eq? subtype 'inline)
+          (alist-walk from type 'list)
+          (lambda _ '("")))))
+
+(define (get-format type subtype) (get-from formats type subtype))
+(define (get-filter type subtype) (get-from filters type subtype))
+
+(define (format-line fmt line type)
+  (cond
+   ;; if LINE is a string, wrap it in a list
+   ((string? line)
+    (set! line (list line)))
+   ;; if it's a list of strings, join them together and filter them
+   ((and (list? line)
+         (string? (car line)))
+    (set! line ((get-filter type 'line) line)))
+   ;; if the car of LINE is a symbol, it's an inline thing.
+   ((and (list? line)
+         (symbol? (car line)))
+    (set! line (format-line (get-format (car line) 'inline)
+                            ((get-filter (car line) 'line) (cdr line))
+                            type)))
+   (else (error "Malformed line" line)))
+  (apply sprintf fmt line))
+
+(define (format-block block)
+  (if (assq (car block) formats)
+      (let* ((type (car block))
+             (data (cdr block))
+             (text (cond
+                    ((string? data) data)
+                    ((list? data)
+                     (apply string-append
+                            (map (lambda (ln)
+                                   (format-line (get-format type 'line)
+                                                ln
+                                                type))
+                                 data)))
+                    (else (error "Malformed block" block)))))
+        (sprintf (get-format type 'block)
+                 ((get-filter type 'block) text)))
+      ""))