6 files changed, 332 insertions, 0 deletions

@@ -0,0 +1,94 @@
+(declare (module (jimmy emit)))
+
+(import scheme (chicken base)
+        (chicken format)
+        (chicken irregex)
+        (chicken port)
+        (chicken string)
+        (only utf8-srfi-13 string-join)
+        (jimmy util))
+
+(define-public (emit doc)
+  (for-each display (map format-stanza doc)))
+
+(define-public (emit-string doc)
+  (with-output-to-string
+    (lambda () (emit doc))))
+
+(define-public formats
+  (make-parameter
+   ;; (TYPE (line . LINE-FMT) (stanza . STANZA-FMT) (inline . INLINE-FMT))
+   '((para (line . "~A")
+           (stanza . "~A~%~%"))
+     (verb (line . "~A~%")
+           (stanza . "```~%~A```~%~%"))
+     (link (line . "=> ~A ~A~%")         ; Note: link has 2 format arguments
+           (stanza . "~A~%")
+           (inline . "~%=> ~A ~A~%"))
+     (list (line . "* ~A~%")
+           (stanza . "~A~%"))
+     (quot (line . "~A")
+           (stanza . "> ~A~%~%"))
+     (hdr1 (line . "# ~A~%")
+           (stanza . "~A~%"))
+     (hdr2 (line . "## ~A~%")
+           (stanza . "~A~%"))
+     (hdr3 (line . "### ~A~%")
+           (stanza . "~A~%")))))
+
+(define-public filters
+  (make-parameter
+   ;; (TYPE (line . LINE-FILTER) (stanza . STANZA-FILTER))
+   ;; line-filter : (lambda (list-of-strs) ...) -> list-of-strs (for format)
+   ;; stanza-filter : (lambda (list-of-strs) ...) -> str
+   `((verb (line . ,identity)
+           (stanza . ,join-lines))
+     (default
+       (line . ,identity)
+       (stanza . ,flush-lines-left)))))
+
+(define (format-line line el)
+  (cond
+   ((string? (car line))                ; regular stanza line
+    (sprintf* (get-format el 'line)
+              ((get-filter el 'line) line)))
+   ((symbol? (car line))                ; inline element
+    (sprintf* (get-format (car line) 'inline)
+              ((get-filter (car line) 'line) (cdr line))))
+   (else (error "Malformed line" line))))
+
+(define (format-stanza stanza)
+  (let* ((type (car stanza))
+         (data (cdr stanza))
+         (text (map (lambda (ln)
+                      (format-line ln type))
+                    data)))
+    (sprintf (get-format type 'stanza)
+             ((get-filter type 'stanza) text))))
+
+;;; Utilities
+
+(define (get-from alist el scope)
+  (or (alist-walk alist el scope)
+      (alist-walk alist 'default scope)
+      (and (eq? scope 'inline)
+           (alist-walk alist 'default 'line))))
+
+(define (get-format el scope)
+  (or (get-from (formats) el scope)
+      ""))
+(define (get-filter el scope) (get-from (filters) el scope))
+
+(define (sprintf* fmt lis)
+  (let loop ((num (length (irregex-extract "~[aA]" fmt)))
+             (lis lis)
+             (out '()))
+    (cond
+     ((null? lis)
+      (apply sprintf fmt (reverse out)))
+     ((= 1 num)
+      (loop 0 '() (cons (string-join lis) out)))
+     (else
+      (loop (- num 1)
+            (cdr lis)
+            (cons (car lis) out))))))
@@ -0,0 +1,61 @@
+(declare (module (jimmy html)))
+
+(import scheme (chicken base)
+        (chicken irregex)
+        (jimmy emit)
+        (jimmy util))
+
+(define (escape-entities s)
+  (irregex-replace/all "[&<>]" s
+                       (lambda (m)
+                         (let ((c (irregex-match-substring m)))
+                           (cond
+                            ((equal? c "&") "&amp;")
+                            ((equal? c "<") "&lt;")
+                            ((equal? c ">") "&gt;"))))))
+
+(define (add-inline-markup s)
+  (define (char->tag ch tag)
+    (lambda (s)
+      (irregex-replace/all `(: ,ch ($ (* (~ ,ch))) ,ch) s
+                           "<" tag ">" 1 "</" tag ">")))
+
+  ((o (char->tag "*" "b")
+      (char->tag "_" "i")
+      (char->tag "`" "code")) s))
+
+(formats
+  '((para (line . "~a~%")
+          (stanza . "<p>~% ~a</p>~%"))
+    (verb (line . "~a~%")
+          (stanza . "<pre><code>~a</code></pre>~%"))
+    (link (line . "<li><a href=\"~a\">~a</a></li>~%")
+          (stanza . "<ul>~% ~a</ul>~%")
+          (inline . "<a href=\"~a\">~a</a>~%"))
+    (list (line . "<li>~a</li>~%")
+          (stanza . "<ul>~% ~a</ul>~%"))
+    (quot (line . "~a~%")
+          (stanza . "<blockquote>~% ~a</blockquote>~%"))
+    (hdr1 (line . "~a")
+          (stanza . "<h1>~a</h1>~%"))
+    (hdr2 (line . "~a")
+          (stanza . "<h2>~a</h2>~%"))
+    (hdr3 (line . "~a")
+          (stanza . "<h3>~a</h3>~%"))))
+
+(filters
+  `((verb (line . ,identity)
+          (stanza . ,join-lines))
+    (link (line . ,(lambda (ln)
+                     (cons (car ln)
+                           ((o list
+                               add-inline-markup
+                               escape-entities
+                               string-join)
+                            (cdr ln))))))
+    (default
+      (line . ,(o list
+                  add-inline-markup
+                  escape-entities
+                  string-join))
+      (stanza . ,string-join))))
@@ -0,0 +1,19 @@
+(declare (module (jimmy main)))
+
+(import scheme (chicken base)
+        (chicken port)
+        (jimmy util)
+        (jimmy read)
+        (jimmy emit)
+        (jimmy wrap))
+
+(define-public (jimmy #!optional file template)
+  (parameterize ((current-input-port
+                  (if file
+                      (open-input-file file)
+                      (current-input-port))))
+    (let ((doc (parse))
+          (post-proc (if template
+                         (cut wrap-with <> template)
+                         emit-string)))
+      (post-proc doc))))
@@ -0,0 +1,88 @@
+(declare (module (jimmy read)))
+
+(import scheme (chicken base)
+        (jimmy util)
+        (only (chicken io) read-lines)
+        (only (chicken string) string-split))
+
+(define-public line-types
+  ;; (sigil type inlines word-select)
+  `((default para (link) ,identity) ; if nothing else matches
+    ("```" verb)
+    ("=>" link)
+    (">" quot)
+    ("#" hdr1)
+    ("##" hdr2)
+    ("###" hdr3)
+    ("*" list)
+    ;; extra!
+    (":" meta)))
+
+(define-public (parse #!optional port)
+  (parse-lines (read-lines (or port (current-input-port))) '()))
+
+(define (line-type line)
+  (let ((lin (if (string? line) (string-split line) line))
+        (def (cdr (assoc 'default line-types))))
+    (cond
+     ((null? lin) def)                             ; empty line
+     ((assoc (car lin) line-types) => cdr)         ; a line type exists
+     (else def))))                                 ; otherwise ...
+
+(define (parse-lines lines doc)
+  (if (null? lines) (reverse doc)
+      (let ((words (string-split (car lines))))
+        (cond
+         ((null? words)                            ; empty line
+          (parse-lines (cdr lines) doc))
+         ((equal? (car words) "```")               ; verbatim
+          ;; Format for verbatim header:
+          ;; ``` ?html | command ...
+          ;;     -- only run command on block with html output.
+          ;;        other outputs process the block normally
+          ;; ``` ?!html | command ...
+          ;;     -- only run command on block when *not* outputting html.
+          ;;        html processes the block normally
+          ;; ``` ?:html | command ...
+          ;;     -- like ?html, but ignore the block in non-html outputs.
+          ;;;; FIXME: I think this necessitates a special emit-verbatim
+          ;;;; function.
+          (parse-verbatim (cdr lines) doc '()
+                   #;       (if (< 1 (length words))
+                              (cons 'verb (cdr words))
+                          'verb)
+                          'verb))
+         (else                                     ; another line type
+          (apply parse-stanza lines doc '() (line-type words)))))))
+
+(define (parse-verbatim lines doc block bhead)
+  (define (close-verbatim) (cons (cons bhead (reverse block)) doc))
+  (cond
+   ((null? lines)                       ; end of document
+    (parse-lines lines (close-verbatim)))
+   ((equal? (car lines) "```")          ; end of verbatim block
+    (parse-lines (cdr lines) (close-verbatim)))
+   (else                                ; verbatim block continues
+    (parse-verbatim (cdr lines) doc (cons (list (car lines)) block) bhead))))
+
+(define (parse-stanza lines doc stanza st-type
+                      #!optional (st-inlines '()) (st-words cdr))
+  (define (close-stanza) (cons (cons st-type (reverse stanza)) doc))
+  (if (null? lines)                                ; end of document
+      (parse-lines lines (close-stanza))
+      (let* ((ln (car lines))
+             (ws (string-split ln))
+             (lt (line-type ln)))
+        (cond
+         ((null? ws)                               ; end of stanza (blank line)
+          (parse-lines (cdr lines) (close-stanza)))
+         ((memq (car lt) st-inlines)               ; in-line for *this* stanza
+          (parse-stanza (cdr lines) doc
+                        (cons (cons (car lt) (cdr ws)) stanza)
+                        st-type st-inlines st-words))
+         ((not (eq? st-type (car (line-type ws)))) ; beginning of a new stanza
+          (parse-lines lines (close-stanza)))
+         (else                                     ; continue this stanza
+          (parse-stanza (cdr lines) doc
+                        (cons (st-words ws) stanza)
+                        st-type st-inlines st-words))))))
@@ -0,0 +1,49 @@
+(module (jimmy util) *
+
+  (import scheme (chicken base)
+          (chicken condition)
+          (only (chicken irregex) irregex-replace/all)
+          (chicken string))
+
+  (define-syntax define-public
+    (syntax-rules ()
+      ((define-public (name . arg) forms ...)
+       (begin (export name)
+              (define (name . arg) forms ...)))
+      ((define-public (name args ...) forms ...)
+       (begin (export name)
+              (define (name args ...) forms ...)))
+      ((define-public name value)
+       (begin (export name)
+              (define name value)))))
+
+  (define-syntax ignore-errors
+    (syntax-rules ()
+      ((ignore-errors x)
+       (handle-exceptions e #f x))))
+
+  (define (alist-walk lis . keys)
+    (if (null? keys)
+        lis
+        (let ((kv (assoc (car keys) lis)))
+          (cond
+           ((not kv) #f)
+           ((atom? (cdr kv))
+            (and (null? (cdr keys))       ; this shouldn't error...
+                 (cdr kv)))
+           ((list? (cdr kv))
+            (apply alist-walk (cdr kv) (cdr keys)))))))
+
+  (define (string-join ss #!optional (sep " "))
+    (string-intersperse ss sep))
+
+  (define (flush-lines-left lines)
+    (irregex-replace/all '(: bol (* space))
+                         (string-join lines) ""))
+
+  (define (join-lines lines)
+    (apply string-append lines))
+
+  )
+
+
@@ -0,0 +1,21 @@
+(declare (module (jimmy wrap)))
+
+(import scheme (chicken base)
+        (jimmy emit)
+        (jimmy util)
+        (only (chicken io) read-string)
+        (only (chicken port) with-output-to-string)
+        (only (chicken string) string-translate* string-intersperse))
+
+;; templates are strings with variables interpolated with "{{variables}}"
+
+(define-public (wrap document template)
+  (let* ((meta (map (lambda (el)
+                      (cons (string-append "{{" (car el) "}}")
+                            (string-intersperse (cdr el) " ")))
+                    (alist-walk document 'meta)))
+         (body (cons "{{body}}" (emit-string document))))
+    (string-translate* template (cons body meta))))
+
+(define-public (wrap-with document file)
+  (wrap document (with-input-from-file file read-string)))