(select-module wiliki) (use srfi-19)
;; Macro alist
(define *reader-macro-alist* '()) (define *writer-macro-alist* '()) (define *virtual-page-alist* '())
;;---------------------------------------------- ;; API called from main WiLiKi system ;;
(define (handle-reader-macro name) (let1 args (string-tokenize name) (cond ((assoc (car args) *reader-macro-alist*) => (lambda (p) (apply (cdr p) (cdr args)))) (else (unrecognized name)))))
(define (handle-writer-macro name) (let1 args (string-tokenize name) (cond ((assoc (car args) *writer-macro-alist*) => (lambda (p) (apply (cdr p) (cdr args)))) (else (unrecognized name)))))
(define (handle-virtual-page name) (cond ((get-virtual-page name) => (lambda (p) ((cdr p) name))) (else (unrecognized name))))
;;---------------------------------------------- ;; Utility to define macros ;;
(define (unrecognized name)
#`",(html-escape-string name)?")
(define-syntax define-reader-macro (syntax-rules () ((_ (name . args) . body) (set! *reader-macro-alist* (let ((sname (string-append "$$" (symbol->string 'name)))) (acons sname (lambda p (if (arity-matches? p 'args) (receive args (apply values p) . body) (unrecognized sname))) *reader-macro-alist*)))) ))
(define-syntax define-writer-macro (syntax-rules () ((_ (name . args) . body) (set! *writer-macro-alist* (let ((sname (string-append "$" (symbol->string 'name)))) (acons sname (lambda p (if (arity-matches? p 'args) (receive args (apply values p) . body) (unrecognized sname))) *writer-macro-alist*)))) ))
(define-syntax define-virtual-page (syntax-rules () ((_ (expr (var ...)) . body) (set! *virtual-page-alist*
(acons expr (lambda p (rxmatch-if (rxmatch expr (car p)) (var ...)
(receive args (apply values p) . body) (unrecognized (regexp->string expr))))
*virtual-page-alist*)))
))
(define (get-virtual-page name) (find (lambda (e) (rxmatch (car e) name)) *virtual-page-alist*))
(define (virtual-page? name) (not (not (get-virtual-page name)))) (define (arity-matches? list formals) (cond ((null? list) (or (null? formals) (not (pair? formals)))) ((null? formals) #f) ((pair? formals) (arity-matches? (cdr list) (cdr formals))) (else #t)))
;;---------------------------------------------- ;; Writer macro definitions ;;
(define-writer-macro (date) (format-time (sys-time)))
;;---------------------------------------------- ;; Reader macro definitions ;;
(define-reader-macro (index prefix) (html:ul (map (lambda (key) (html:li (wikiname-anchor (car key)))) (wdb-search (db) (lambda (k v) (string-prefix? prefix k))))))
(define-reader-macro (cindex prefix . maybe-delim) (fold-right (lambda (key r) (if (null? r) (list (wikiname-anchor (car key))) (cons* (wikiname-anchor (car key)) (get-optional maybe-delim "") " " r))) '() (wdb-search (db) (lambda (k v) (string-prefix? prefix k)))))
;(define-reader-macro (anchor name . maybe-tag) ; (html:a :name name
(define-reader-macro (include page)
(cond ((wdb-get (db) page) => format-content)
(else #`"$$include ,(html-escape-string page)?")))
(define-reader-macro (img url . maybe-alt) (define (alt) (if (null? maybe-alt) "[image]" (string-join maybe-alt " "))) (define (badimg) (html:a :href url (alt))) (let loop ((urls (image-urls-of (wiliki)))) (if (pair? urls) (receive (pred action) (if (pair? (car urls)) (values (caar urls) (cadar urls)) (values (car urls) 'allow)) (if (pred url) (if (eq? action 'allow) (html:img :src url :alt (alt)) (badimg)) (loop (cdr urls)))) (badimg))))
(define-reader-macro (toc . maybe-page) (define (anchor id line) (if (null? maybe-page) (html:a :href #`"#,id" (html-escape-string line)) (html:a :href #`",(url \"p=~a\" (car maybe-page))#,id" (html-escape-string line)))) (define (make-toc page) (with-input-from-string (content-of page) (lambda () (let loop ((line (read-line)) (depth 0) (r '()) (id 0)) (cond ((eof-object? line) (reverse (append (make-list depth "</ul>") r))) ((string=? line "{{{") ;; need to skip <pre> section (let skip ((line (read-line))) (cond ((eof-object? line) (loop line depth r id)) ((string=? line "}}}") (loop (read-line) depth r id)) (else (skip (read-line)))))) ((rxmatch #/^\*+ / line) => (lambda (m) (let1 newdepth (- (string-length (m)) 1) (cond ((= newdepth depth) (loop (read-line) newdepth (cons* (anchor id (rxmatch-after m)) "<li> " r) (+ id 1))) ((> newdepth depth) (loop (read-line) newdepth (cons* (anchor id (rxmatch-after m)) "<li> " (make-list (- newdepth depth) "<ul>") r) (+ id 1))) (else (loop (read-line) newdepth (cons* (anchor id (rxmatch-after m)) "<li>" (make-list (- depth newdepth) "</ul>") r) (+ id 1))) )))) (else (loop (read-line) depth r id))))))) (if (null? maybe-page) (cond ((wdb-get (db) (key-of (current-formatting-page))) => make-toc) (else #f"`$$toc?")) (cond ((wdb-get (db) (car maybe-page)) => make-toc) (else #`"$$toc ,(html-escape-string page)?"))) )
;;---------------------------------------------- ;; Virtual page definitions ;;
;; This is just a sample.
(define-virtual-page (#/^RecentChanges$/ (_)) (html:table (map (lambda (p) (html:tr (html:td (format-time (cdr p))) (html:td "(" (how-long-since (cdr p)) " ago)") (html:td (wikiname-anchor (car p))))) (wdb-recent-changes (db)))))