Scheme bit!

5 files changed, 236 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)))
+      ""))
@@ -0,0 +1,3 @@
+(declare (module (jimmy html)))
+
+
@@ -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)))))
@@ -0,0 +1,37 @@
+(module (jimmy util) *
+
+  (import scheme (chicken base)
+          (chicken condition))
+
+  (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)))))))
+
+  )
+
+
@@ -0,0 +1,13 @@
+(declare (module (jimmy wrap)))
+
+(import scheme (chicken base)
+        (jimmy util)
+        (chicken format))
+
+;;; open question: how to do templating?
+
+(define-public (wrap document template)
+  #f)
+
+(define (meta-get key document)
+  (alist-walk document 'meta key))