132 lines
5.4 KiB
Racket
132 lines
5.4 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base)
|
|
scribble/base
|
|
scribble/core)
|
|
(provide 2dtabular)
|
|
(define-syntax (2dtabular stx)
|
|
(syntax-case stx ()
|
|
[(_ cols rows cells ...)
|
|
(let ()
|
|
(define row-count (length (syntax->list #'rows)))
|
|
(define col-count (length (syntax->list #'cols)))
|
|
(define table (make-hash))
|
|
(define the-sep #f)
|
|
(define the-style #f)
|
|
(define ignore-first-line? #f)
|
|
(define has-keywords? #f)
|
|
(for ([cell (in-list (syntax->list #'(cells ...)))])
|
|
(syntax-case cell ()
|
|
[[(coord ...) body ...]
|
|
(let ()
|
|
(define coords
|
|
(sort
|
|
(for/list ([coord (in-list (syntax->list #'(coord ...)))])
|
|
(define lst (syntax->datum coord))
|
|
(cons (car lst)
|
|
(cadr lst)))
|
|
<
|
|
#:key car))
|
|
(define bodies (syntax->list #'(body ...)))
|
|
(unless (or (null? (cdr coords)) (apply = (map cdr coords)))
|
|
(raise-syntax-error '2dtabular
|
|
"cells may not span rows"
|
|
stx
|
|
#f
|
|
bodies))
|
|
(define keyword-line?
|
|
(and (= (+ (cdr (car coords)) 1) row-count)
|
|
(= (length coords) col-count)
|
|
(ormap (λ (x) (keyword? (syntax-e x))) bodies)))
|
|
(when keyword-line? (set! has-keywords? #t))
|
|
(cond
|
|
[keyword-line?
|
|
;; last row, spans the entire table, contains keywords
|
|
;; => treat as keyword arguments to tabular
|
|
(let loop ([bodies bodies])
|
|
(syntax-case bodies ()
|
|
[(#:style style-arg . rest)
|
|
(begin
|
|
(set! the-style #'style-arg)
|
|
(loop #'rest))]
|
|
[(#:style)
|
|
(raise-syntax-error '2dtabular
|
|
"expected a style to follow the #:style keyword"
|
|
stx
|
|
(car bodies))]
|
|
[(#:sep sep-arg . rest)
|
|
(begin
|
|
(set! the-sep #'sep-arg)
|
|
(loop #'rest))]
|
|
[(#:sep)
|
|
(raise-syntax-error '2dtabular
|
|
"expected a separator to follow the #:sep keyword"
|
|
stx
|
|
(car bodies))]
|
|
[(#:ignore-first-row . rest)
|
|
(begin (set! ignore-first-line? #t)
|
|
(loop #'rest))]
|
|
[() (void)]
|
|
[(a . b)
|
|
(cond
|
|
[(special-comment? (syntax-e #'a))
|
|
(loop #'b)]
|
|
[else
|
|
(raise-syntax-error '2dtabular
|
|
"expected either the keyword #:style #:sep or #:ignore-first-row"
|
|
stx
|
|
#'a)])]))]
|
|
[else
|
|
(define no-comment-bodies
|
|
(for/list ([body (in-list bodies)]
|
|
#:unless (special-comment? (syntax-e body)))
|
|
(when (keyword? (syntax-e body))
|
|
(raise-syntax-error '2dtabular
|
|
"unexpected keyword"
|
|
stx
|
|
body))
|
|
body))
|
|
(hash-set! table
|
|
(car coords)
|
|
#`(build-block #,@no-comment-bodies))
|
|
(for ([coord (in-list (cdr coords))])
|
|
(hash-set! table coord #''cont))]))]))
|
|
#`(tabular #,@(if the-style #`(#:style #,the-style) #'())
|
|
#,@(if the-sep #`(#:sep #,the-sep) #'())
|
|
(list #,@(for/list ([y (in-range
|
|
(if ignore-first-line? 1 0)
|
|
(if has-keywords?
|
|
(- row-count 1)
|
|
row-count))])
|
|
#`(list #,@(for/list ([x (in-range col-count)])
|
|
(hash-ref table (cons x y))))))))]))
|
|
|
|
(define (build-block . block-or-contents)
|
|
(define (build-block pending)
|
|
(paragraph (style #f '()) (reverse pending)))
|
|
|
|
(define blocks
|
|
(let loop ([args block-or-contents]
|
|
[pending '()])
|
|
(cond
|
|
[(null? args)
|
|
(if (null? pending)
|
|
'()
|
|
(list (build-block pending)))]
|
|
[else
|
|
(define arg (car args))
|
|
(cond
|
|
[(content? arg)
|
|
(loop (cdr args) (cons arg pending))]
|
|
[else
|
|
(if (null? pending)
|
|
(cons arg (loop (cdr args) '()))
|
|
(list* (build-block pending)
|
|
arg
|
|
(loop (cdr args) '())))])])))
|
|
|
|
(nested-flow (style #f '()) blocks))
|
|
|
|
|
|
|
|
|
|
|