Scheme bit!

1 files changed, 74 insertions, 0 deletions

@@ -0,0 +1,74 @@
+(declare (module (jimmy read)))
+
+(import scheme (chicken base)
+        (jimmy util)
+        (only (chicken condition) handle-exceptions)
+        (only (chicken io) read-lines)
+        (only (chicken string) string-split))
+
+(define-public line-types
+  ;; (sigil type inlines preproc)
+  '(("=>" link)
+    (">" quot)
+    ("#" hdr1)
+    ("##" hdr2)
+    ("###" hdr3)
+    ("*" list)
+    ("```" verb)
+    ;; extra!
+    (":" meta)))
+
+(define-public (parse inport)
+  (parse-lines (read-lines inport) '()))
+
+(define (line-type line)
+  (let ((it (assoc (car (string-split line)) line-types)))
+    (if it (cadr it)
+        'para)))
+
+(define (parse-lines lines document)
+  (if (null? lines) (reverse document)
+      (let ((words (string-split (car lines))))
+        (cond
+         ((null? words)
+          (parse-lines (cdr lines) document))
+         ((equal? (car words) "```")
+          (parse-verbatim (cdr lines) document '()))
+         ((assoc (car words) line-types)
+          => (lambda (it)
+               (apply parse-block lines document '() (cdr it))))
+         (else
+          (parse-block lines document '() 'para '(link) identity))))))
+
+(define (parse-verbatim lines document verb)
+  (cond
+   ((null? lines)
+    (parse-lines lines (cons (cons 'verb (reverse verb)) document)))
+   ((equal? (car lines) "```")
+    (parse-lines (cdr lines) (cons (cons 'verb (reverse verb)) document)))
+   (else
+    (parse-verbatim (cdr lines) document (cons (car lines) verb)))))
+
+(define (parse-block lines document block type #!optional inlines preproc)
+  (let ((inlines (or inlines '()))
+        (preproc (or preproc (lambda (ln) (cdr (string-split ln))))))
+    (cond
+     ((null? lines)
+      (parse-lines lines (cons (cons type (reverse block)) document)))
+     ((equal? (car lines) "")
+      (parse-lines (cdr lines) (cons (cons type (reverse block)) document)))
+     ((and (not (eq? type (line-type (car lines))))
+           (not (memq (line-type (car lines)) inlines)))
+      (parse-lines lines (cons (cons type (reverse block)) document)))
+     ((memq (line-type (car lines)) inlines)
+      (let* ((ln (car lines))
+             (ws (string-split ln))
+             (lt (cdr (assoc (car ws) line-types))))
+        (parse-block (cdr lines) document
+                     (cons (cons (car lt)
+                                 ((or (ignore-errors (caddr lt)) cdr) ws))
+                           block)
+                     type inlines preproc)))
+     (else
+      (parse-block (cdr lines) document (cons (preproc (car lines)) block)
+                   type inlines preproc)))))