manual-vars.rkt (10299B)
1 #lang scheme/base 2 (require "../decode.rkt" 3 "../scheme.rkt" 4 "../struct.rkt" 5 (only-in "../core.rkt" 6 make-style style-name style-properties 7 nested-flow? nested-flow-blocks nested-flow-style 8 make-nested-flow) 9 "../html-properties.rkt" 10 racket/contract/base 11 (for-syntax scheme/base 12 syntax/kerncase 13 syntax/boundmap) 14 (for-label scheme/base 15 scheme/class)) 16 17 (define-struct (box-splice splice) ()) 18 19 (provide/contract 20 [struct (box-splice splice) ([run list?])]) ; XXX ugly copying 21 (provide deftogether *deftogether 22 with-racket-variables 23 with-togetherable-racket-variables 24 vertical-inset-style 25 boxed-style 26 add-background-label) 27 28 (define vertical-inset-style 29 (make-style 'vertical-inset null)) 30 31 (define boxed-style 32 (make-style 'boxed (list (make-attributes (list (cons 'class "RBoxed")))))) 33 34 (define ((add-background-label what) l) 35 (list 36 (make-nested-flow 37 (make-style "RBackgroundLabel" (list 'decorative 'command (alt-tag "div") 38 (make-attributes '((class . "SIEHidden"))))) 39 (list 40 (make-nested-flow 41 (make-style "RBackgroundLabelInner" (list (alt-tag "div"))) 42 (list (make-omitable-paragraph what))))) 43 (let* ([a (car l)] 44 [remake (if (paragraph? a) 45 (lambda (sa) 46 (paragraph 47 (sa (paragraph-style a)) 48 (paragraph-content a))) 49 (lambda (sa) 50 (table 51 (sa (table-style a)) 52 (table-blockss a))))]) 53 (remake 54 (lambda (s) 55 (make-style (style-name s) 56 (let ([p (style-properties s)]) 57 (if (ormap attributes? p) 58 (for/list ([i (in-list p)]) 59 (if (attributes? i) 60 (let ([al (attributes-assoc i)]) 61 (if (assq 'class al) 62 (for/list ([a (in-list al)]) 63 (if (eq? (car a) 'class) 64 (cons 'class (string-append (cdr a) " RForeground")) 65 a)) 66 (attributes (cons '(class . "RForeground") 67 al)))) 68 i)) 69 (cons (attributes '((class . "RForeground"))) 70 p))))))))) 71 72 (begin-for-syntax (define-struct deftogether-tag () #:omit-define-syntaxes)) 73 74 (define-syntax (with-togetherable-racket-variables stx) 75 (syntax-case stx () 76 [(_ lits vars decl) 77 (with-syntax ([vars (syntax-property #'vars 'taint-mode 'none)]) 78 (syntax-property 79 #'(with-togetherable-racket-variables* lits vars decl) 80 'taint-mode 81 'transparent))])) 82 83 (define-syntax-rule (with-togetherable-racket-variables* . rest) 84 (with-racket-variables . rest)) 85 86 (define-syntax (with-racket-variables stx) 87 (syntax-case stx () 88 [(_ lits ([kind s-exp] ...) body) 89 (let ([ht (make-bound-identifier-mapping)] 90 [lits (syntax->datum #'lits)]) 91 (for-each (lambda (kind s-exp) 92 (case (syntax-e kind) 93 [(proc) 94 (letrec ([do-proc 95 (lambda (s-exp) 96 (let ([s-exp (syntax->list s-exp)]) 97 (for-each 98 (lambda (arg) 99 (if (identifier? arg) 100 (unless (or (eq? (syntax-e arg) '...) 101 (eq? (syntax-e arg) '...+) 102 (eq? (syntax-e arg) '_...superclass-args...) 103 (memq (syntax-e arg) lits)) 104 (bound-identifier-mapping-put! ht arg #t)) 105 (syntax-case arg () 106 [(kw arg . rest) 107 (and (keyword? (syntax-e #'kw)) 108 (identifier? #'arg)) 109 (bound-identifier-mapping-put! ht #'arg #t)] 110 [(arg . rest) 111 (identifier? #'arg) 112 (bound-identifier-mapping-put! ht #'arg #t)] 113 [else (void)]))) 114 (cdr s-exp)) 115 (unless (identifier? (car s-exp)) 116 ;; Curried: 117 (do-proc (car s-exp)))))]) 118 (do-proc s-exp))] 119 [(form form/none form/maybe non-term) 120 (define skip-id (case (syntax-e kind) 121 [(form) 122 (syntax-case s-exp () 123 [(defined-id actual-s-exp) (let ([id #'defined-id]) 124 (and (identifier? id) 125 id))] 126 [_ #f])] 127 [else #f])) 128 (let loop ([form (case (syntax-e kind) 129 [(form) 130 (syntax-case s-exp () 131 [(defined-id actual-s-exp) #'actual-s-exp])] 132 [(form/none) s-exp] 133 [(form/maybe) 134 (syntax-case s-exp () 135 [(#f form) #'form] 136 [(#t (id . form)) #'form])] 137 [(non-term) s-exp])]) 138 (if (identifier? form) 139 (unless (or (and skip-id 140 (free-identifier=? skip-id form)) 141 (eq? (syntax-e form) '...) 142 (eq? (syntax-e form) '...+) 143 (eq? (syntax-e form) 'code:line) 144 (eq? (syntax-e form) 'code:blank) 145 (eq? (syntax-e form) 'code:comment) 146 (eq? (syntax-e form) '?) 147 (memq (syntax-e form) lits)) 148 (bound-identifier-mapping-put! ht form #t)) 149 (syntax-case form (unsyntax) 150 [(unsyntax _) (void)] 151 [(a . b) (loop #'a) (loop #'b)] 152 [#(a ...) (loop #'(a ...))] 153 [_ (void)])))] 154 [else 155 (raise-syntax-error 156 #f 157 "unknown variable mode" 158 stx 159 kind)])) 160 (syntax->list #'(kind ...)) 161 (syntax->list #'(s-exp ...))) 162 (with-syntax ([(id ...) (bound-identifier-mapping-map ht (lambda (k v) k))]) 163 #'(letrec-syntaxes ([(id) (make-variable-id 'id)] ...) 164 body)))])) 165 166 167 (define (*deftogether boxes body-thunk) 168 (make-box-splice 169 (cons 170 (make-blockquote 171 vertical-inset-style 172 (list 173 (make-table 174 boxed-style 175 (map 176 (lambda (box) 177 (unless (and (box-splice? box) 178 (= 1 (length (splice-run box))) 179 (nested-flow? (car (splice-run box))) 180 (eq? vertical-inset-style (nested-flow-style (car (splice-run box)))) 181 (let ([l (nested-flow-blocks (car (splice-run box)))]) 182 (= 1 (length l)) 183 (table? (car l)) 184 (eq? boxed-style (table-style (car l))))) 185 (error 'deftogether 186 "element is not a boxing splice containing a single nested-flow with a single table: ~e" 187 box)) 188 (list (make-flow (list (make-table 189 "together" 190 (table-flowss (car (nested-flow-blocks (car (splice-run box)))))))))) 191 boxes)))) 192 (body-thunk)))) 193 194 (define-syntax (deftogether stx) 195 (syntax-case stx () 196 [(_ (def ...) . body) 197 (with-syntax ([((_ (lit ...) (var ...) decl) ...) 198 (map (lambda (def) 199 (let ([exp-def (local-expand 200 def 201 (list (make-deftogether-tag)) 202 (cons 203 #'with-togetherable-racket-variables* 204 (kernel-form-identifier-list)))]) 205 (syntax-case exp-def (with-togetherable-racket-variables*) 206 [(with-togetherable-racket-variables* lits vars decl) 207 exp-def] 208 [_ 209 (raise-syntax-error 210 #f 211 "sub-form is not a documentation form that can be combined" 212 stx 213 def)]))) 214 (syntax->list #'(def ...)))]) 215 #'(with-togetherable-racket-variables 216 (lit ... ...) 217 (var ... ...) 218 (*deftogether (list decl ...) (lambda () (list . body)))))]))