74 lines
3.0 KiB
Scheme
74 lines
3.0 KiB
Scheme
(module scribble mzscheme
|
|
(require (prefix a: "reader.ss") (lib "kw.ss") (lib "list.ss"))
|
|
(provide (all-from-except mzscheme read read-syntax define lambda)
|
|
(rename a:read read) (rename a:read-syntax read-syntax)
|
|
(rename define/kw define) (rename lambda/kw lambda))
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Utilities
|
|
|
|
(define-syntax define*
|
|
(syntax-rules ()
|
|
[(_ (name . args) . body)
|
|
(begin (provide name) (define/kw (name . args) . body))]
|
|
[(_ name val)
|
|
(begin (provide name) (define name val))]))
|
|
|
|
(define-syntax define-format-element
|
|
(syntax-rules ()
|
|
([_ name tag]
|
|
(begin (define (name . args) (cons tag args))
|
|
(provide name)))))
|
|
|
|
;; allows specifying attributes through sub-elements
|
|
(define (subs->keys x keys)
|
|
(let ([syms+keys
|
|
(append (map (lambda (k) (string->symbol (keyword->string k))) keys)
|
|
keys)]
|
|
[tag (car x)])
|
|
(define (amb-error key)
|
|
(error tag "ambiguous `~a' specification" key))
|
|
(let loop ([xs (cdr x)] [kvs '()] [seen '()])
|
|
(if (not (or (null? xs) (null? (cdr xs)) (not (keyword? (car xs)))))
|
|
(let ([key (car xs)])
|
|
(when (memq key seen) (amb-error key))
|
|
(loop (cddr xs) (list* (cadr xs) key kvs) (cons key seen)))
|
|
(let loop ([xs xs] [body '()] [seen seen])
|
|
(cond [(null? xs)
|
|
(cons tag (append (reverse kvs) (reverse body)))]
|
|
[(or (not (pair? (car xs))) (not (memq (caar xs) syms+keys)))
|
|
(loop (cdr xs) (cons (car xs) body) seen)]
|
|
[else
|
|
(let ([key (if (keyword? (caar xs))
|
|
(caar xs)
|
|
(string->keyword (symbol->string (caar xs))))])
|
|
(when (memq key seen) (amb-error (caar xs)))
|
|
(when (and (pair? (cdar xs)) (keyword? (cadar xs)))
|
|
(error tag "sub-element for `~s' key as its own keys"
|
|
(caar xs)))
|
|
(set! kvs (list* (cdar xs) key kvs))
|
|
(loop (cdr xs) body (cons key seen)))]))))))
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Formatting values and functions
|
|
|
|
(define* (document . body)
|
|
(subs->keys (cons 'document body) '(#:title #:author #:date)))
|
|
|
|
(define-format-element b 'bold)
|
|
(define-format-element bf 'bold)
|
|
(define-format-element bold 'bold)
|
|
(define-format-element i 'italic)
|
|
(define-format-element it 'italic)
|
|
(define-format-element italic 'italic)
|
|
(define-format-element u 'underline)
|
|
(define-format-element ul 'underline)
|
|
(define-format-element underline 'underline)
|
|
(define-format-element tt 'tt)
|
|
|
|
(define-format-element title 'title)
|
|
(define-format-element author 'author)
|
|
;; (define-format-element date 'date)
|
|
|
|
)
|