/usr/share/racket/pkgs/2d-lib/tabular.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | #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))
|