about summary refs log tree commit diff stats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/emit.scm109
-rw-r--r--src/html.scm3
-rw-r--r--src/read.scm74
-rw-r--r--src/util.scm37
-rw-r--r--src/wrap.scm13
5 files changed, 236 insertions, 0 deletions
diff --git a/src/emit.scm b/src/emit.scm new file mode 100644 index 0000000..aa36eb5 --- /dev/null +++ b/src/emit.scm
@@ -0,0 +1,109 @@
1(declare (module (jimmy emit)))
2
3(import scheme (chicken base)
4 (jimmy util)
5 (chicken format)
6 (chicken irregex)
7 (chicken string))
8
9(define-public (emit document)
10 (for-each display
11 (map format-block document)))
12
13(define-public formats
14 ;;; (type line-format block-format [line-in-block-format])
15 ;; these default to gemtext
16 '((para (line . "~A ")
17 (block . "~A~%~%"))
18 (verb (line . "~A~%")
19 (block . "```~%~A```~%~%"))
20 (link (line . "=> ~A ~A~%")
21 (block . "~A~%")
22 (inline . "~%=> ~A ~A~%")) ;TODO: have 2 args to format
23 (list (line . "* ~A~%")
24 (block . "~A~%"))
25 (quot (line . "~A ")
26 (block . "> ~A~%~%"))
27 (hdr1 (line . "# ~A~%")
28 (block . "~A~%"))
29 (hdr2 (line . "## ~A~%")
30 (block . "~A~%"))
31 (hdr3 (line . "### ~A~%")
32 (block . "~A~%"))
33 (default
34 (line . "~A")
35 (block . "~A~%~%"))))
36
37(define (string-join ss #!optional sep)
38 (if (string? ss) ss
39 (string-intersperse ss (or sep " "))))
40
41(define (char->tag char beg end)
42 (lambda (str)
43 (irregex-replace/all `(: ($ (or bos space))
44 ,char ($ (+ (~ ,char))) ,char
45 ($ (or space eos)))
46 str
47 1 beg 2 end 3)))
48
49(define-public filters
50 `((para
51 (line . ,(o (char->tag "*" "<strong>" "</strong>")
52 (char->tag "_" "<em>" "</em>")
53 (char->tag "`" "<code>" "</code>")
54 string-join))
55 (block . ,(lambda (ln)
56 (irregex-replace/all '(: bol (* " ")) ln ""))))
57 (link
58 (line . ,(lambda (ln)
59 (let ((ws (cond ((list? ln) ln)
60 ((string? ln) (string-split ln)))))
61 (list (car ws) (string-join (cdr ws)))))))
62 (default
63 (line . ,list)
64 (block . ,identity))))
65
66(define (get-from from type subtype)
67 (or (alist-walk from type subtype)
68 (if (eq? subtype 'inline)
69 (alist-walk from type 'list)
70 (lambda _ '("")))))
71
72(define (get-format type subtype) (get-from formats type subtype))
73(define (get-filter type subtype) (get-from filters type subtype))
74
75(define (format-line fmt line type)
76 (cond
77 ;; if LINE is a string, wrap it in a list
78 ((string? line)
79 (set! line (list line)))
80 ;; if it's a list of strings, join them together and filter them
81 ((and (list? line)
82 (string? (car line)))
83 (set! line ((get-filter type 'line) line)))
84 ;; if the car of LINE is a symbol, it's an inline thing.
85 ((and (list? line)
86 (symbol? (car line)))
87 (set! line (format-line (get-format (car line) 'inline)
88 ((get-filter (car line) 'line) (cdr line))
89 type)))
90 (else (error "Malformed line" line)))
91 (apply sprintf fmt line))
92
93(define (format-block block)
94 (if (assq (car block) formats)
95 (let* ((type (car block))
96 (data (cdr block))
97 (text (cond
98 ((string? data) data)
99 ((list? data)
100 (apply string-append
101 (map (lambda (ln)
102 (format-line (get-format type 'line)
103 ln
104 type))
105 data)))
106 (else (error "Malformed block" block)))))
107 (sprintf (get-format type 'block)
108 ((get-filter type 'block) text)))
109 ""))
diff --git a/src/html.scm b/src/html.scm new file mode 100644 index 0000000..371d407 --- /dev/null +++ b/src/html.scm
@@ -0,0 +1,3 @@
1(declare (module (jimmy html)))
2
3
diff --git a/src/read.scm b/src/read.scm new file mode 100644 index 0000000..00ffad4 --- /dev/null +++ b/src/read.scm
@@ -0,0 +1,74 @@
1(declare (module (jimmy read)))
2
3(import scheme (chicken base)
4 (jimmy util)
5 (only (chicken condition) handle-exceptions)
6 (only (chicken io) read-lines)
7 (only (chicken string) string-split))
8
9(define-public line-types
10 ;; (sigil type inlines preproc)
11 '(("=>" link)
12 (">" quot)
13 ("#" hdr1)
14 ("##" hdr2)
15 ("###" hdr3)
16 ("*" list)
17 ("```" verb)
18 ;; extra!
19 (":" meta)))
20
21(define-public (parse inport)
22 (parse-lines (read-lines inport) '()))
23
24(define (line-type line)
25 (let ((it (assoc (car (string-split line)) line-types)))
26 (if it (cadr it)
27 'para)))
28
29(define (parse-lines lines document)
30 (if (null? lines) (reverse document)
31 (let ((words (string-split (car lines))))
32 (cond
33 ((null? words)
34 (parse-lines (cdr lines) document))
35 ((equal? (car words) "```")
36 (parse-verbatim (cdr lines) document '()))
37 ((assoc (car words) line-types)
38 => (lambda (it)
39 (apply parse-block lines document '() (cdr it))))
40 (else
41 (parse-block lines document '() 'para '(link) identity))))))
42
43(define (parse-verbatim lines document verb)
44 (cond
45 ((null? lines)
46 (parse-lines lines (cons (cons 'verb (reverse verb)) document)))
47 ((equal? (car lines) "```")
48 (parse-lines (cdr lines) (cons (cons 'verb (reverse verb)) document)))
49 (else
50 (parse-verbatim (cdr lines) document (cons (car lines) verb)))))
51
52(define (parse-block lines document block type #!optional inlines preproc)
53 (let ((inlines (or inlines '()))
54 (preproc (or preproc (lambda (ln) (cdr (string-split ln))))))
55 (cond
56 ((null? lines)
57 (parse-lines lines (cons (cons type (reverse block)) document)))
58 ((equal? (car lines) "")
59 (parse-lines (cdr lines) (cons (cons type (reverse block)) document)))
60 ((and (not (eq? type (line-type (car lines))))
61 (not (memq (line-type (car lines)) inlines)))
62 (parse-lines lines (cons (cons type (reverse block)) document)))
63 ((memq (line-type (car lines)) inlines)
64 (let* ((ln (car lines))
65 (ws (string-split ln))
66 (lt (cdr (assoc (car ws) line-types))))
67 (parse-block (cdr lines) document
68 (cons (cons (car lt)
69 ((or (ignore-errors (caddr lt)) cdr) ws))
70 block)
71 type inlines preproc)))
72 (else
73 (parse-block (cdr lines) document (cons (preproc (car lines)) block)
74 type inlines preproc)))))
diff --git a/src/util.scm b/src/util.scm new file mode 100644 index 0000000..7bf89ac --- /dev/null +++ b/src/util.scm
@@ -0,0 +1,37 @@
1(module (jimmy util) *
2
3 (import scheme (chicken base)
4 (chicken condition))
5
6 (define-syntax define-public
7 (syntax-rules ()
8 ((define-public (name . arg) forms ...)
9 (begin (export name)
10 (define (name . arg) forms ...)))
11 ((define-public (name args ...) forms ...)
12 (begin (export name)
13 (define (name args ...) forms ...)))
14 ((define-public name value)
15 (begin (export name)
16 (define name value)))))
17
18 (define-syntax ignore-errors
19 (syntax-rules ()
20 ((ignore-errors x)
21 (handle-exceptions e #f x))))
22
23 (define (alist-walk lis . keys)
24 (if (null? keys)
25 lis
26 (let ((kv (assoc (car keys) lis)))
27 (cond
28 ((not kv) #f)
29 ((atom? (cdr kv))
30 (and (null? (cdr keys)) ; this shouldn't error...
31 (cdr kv)))
32 ((list? (cdr kv))
33 (apply alist-walk (cdr kv) (cdr keys)))))))
34
35 )
36
37
diff --git a/src/wrap.scm b/src/wrap.scm new file mode 100644 index 0000000..3537dea --- /dev/null +++ b/src/wrap.scm
@@ -0,0 +1,13 @@
1(declare (module (jimmy wrap)))
2
3(import scheme (chicken base)
4 (jimmy util)
5 (chicken format))
6
7;;; open question: how to do templating?
8
9(define-public (wrap document template)
10 #f)
11
12(define (meta-get key document)
13 (alist-walk document 'meta key))