(module gmi ( *strict-gemtext-headers* gmi:read gmi:text gmi:header gmi:link gmi:list gmi:list* gmi:blockquote gmi:code gmi:code* gmi:text? gmi:header? gmi:link? gmi:list? gmi:blockquote? gmi:code? gmi:header:level gmi:header:text gmi:link:uri gmi:link:text gmi:list:items gmi:blockquote:text gmi:code:text gmi:code:lines ) (import scheme (only (chicken base) cute fixnum? make-parameter receive) (only (chicken io) read-lines) (only (chicken irregex) irregex irregex-match irregex-match-substring)) (define (gmi:text text) text) (define (gmi:header level title) `(header ,level ,title)) (define (gmi:link uri text) `(link ,uri ,text)) (define (gmi:list* items) `(list . ,items)) (define (gmi:list . items) (gmi:list* items)) (define (gmi:blockquote text) `(blockquote ,text)) (define (gmi:code* lines) `(code . ,lines)) (define (gmi:code alt-text . lines) (gmi:code* (cons alt-text lines))) (define (tagged-list? tag l) (and (list? l) (not (null? l)) (eq? (car l) tag))) (define (all p? l) (or (null? l) (and (p? (car l)) (all p? (cdr l))))) (define (tag? tag) (cute eq? <> tag)) (define (elem-type? . preds?) (let ((preds-len (length preds?))) (lambda (l) (and (list? l) (let loop ((preds? preds?) (l l)) (cond ((null? l) (null? preds?)) ((null? preds?) #f) (else (let ((h (car l)) (t (cdr l)) (h? (car preds?)) (t? (cdr preds?))) (and (h? h) (loop t? t)))))))))) (define gmi:text? string?) (define gmi:header? (elem-type? (tag? 'header) fixnum? gmi:text?)) (define gmi:link? (elem-type? (tag? 'link) gmi:text? gmi:text?)) (define (gmi:list? l) (and (tagged-list? 'list l) (not (null? (cdr l))) (all gmi:text? (cdr l)))) (define gmi:blockquote? (elem-type? (tag? 'blockquote) gmi:text?)) (define (gmi:code? l) (and (tagged-list? 'code l) (not (null? (cdr l))) (gmi:text? (cadr l)) (all gmi:text? (cddr l)))) (define gmi:header:level cadr) (define gmi:header:text caddr) (define gmi:link:uri cadr) (define gmi:link:text caddr) (define gmi:list:items cdr) (define gmi:blockquote:text cadr) (define gmi:code:text cadr) (define gmi:code:lines cddr) ;;; If enabled (default), header lines of level > 3 are not considered ;;; headers but normal text instead. (define *strict-gemtext-headers* (make-parameter #t)) (define (gmi:read #!optional (port (current-input-port))) ;; Predicates return either an irregex match object if the regex matches ;; the line, or #f otherwise (define (match? re) (cute irregex-match (irregex re) <>)) (define p:header? (match? "(#+)\\s+(.*)")) (define p:link? (match? "=>\\s*([^\\s]+)(\\s+(.*))?")) (define p:list-item? (match? "\\*\\s+(.*)")) (define p:blockquote? (match? ">\\s*(.*)")) (define p:begin-code-line? (match? "```(.*)")) (define p:end-code-line? (cute string=? "```" <>)) (define-syntax match-let (syntax-rules () ((match-let match ((var idx) ...) body ...) (let ((%match match)) (receive (var ...) (values (irregex-match-substring %match idx) ...) body ...))))) (define ((p:header line) ret match) (match-let match ((level 1) (title 2)) (let* ((level (string-length level)) (elem (if (and (> level 3) (*strict-gemtext-headers*)) line (gmi:header level title)))) (cons elem ret)))) (define (p:link ret match) (match-let match ((uri 1) (text 3)) (let ((text (or text ""))) (cons (gmi:link uri text) ret)))) (define (p:list-item ret match) (match-let match ((text 1)) (cons text ret))) (define (p:blockquote ret match) (match-let match ((text 1)) (cons (gmi:blockquote text) ret))) (define (p:end-list items ret) (cons (gmi:list* (reverse items)) ret)) (define (p:begin-code ret match) (match-let match ((text 1)) (cons text ret))) (define (p:end-code code-lines ret) (cons (gmi:code* (reverse code-lines)) ret)) (define (p:text ret txt) (cons (gmi:text txt) ret)) (define eof? null?) (define finish-off reverse) (define ((goto st piece ret tail) match) (st (piece ret match) tail)) (define ((st:list ret) items lines) (if (eof? lines) (finish-off (p:end-list items ret)) (let ((head (car lines)) (tail (cdr lines))) (cond ((p:list-item? head) => (goto (st:list ret) p:list-item items tail)) (else (st:text (p:end-list items ret) lines)))))) (define ((st:code ret) code-lines lines) (if (eof? lines) (finish-off (p:end-code code-lines ret)) (let ((head (car lines)) (tail (cdr lines))) (cond ((p:end-code-line? head) (st:text (p:end-code code-lines ret) tail)) (else ((st:code ret) (cons head code-lines) tail)))))) (define (st:text ret lines) (if (eof? lines) (finish-off ret) (let ((head (car lines)) (tail (cdr lines))) (cond ((p:header? head) => (goto st:text (p:header head) ret tail)) ((p:link? head) => (goto st:text p:link ret tail)) ((p:list-item? head) => (goto (st:list ret) p:list-item '() tail)) ((p:blockquote? head) => (goto st:text p:blockquote ret tail)) ((p:begin-code-line? head) => (goto (st:code ret) p:begin-code '() tail)) (else ((goto st:text p:text ret tail) head)))))) (st:text '() (read-lines port))) )