lp.rkt (14088B)
1 #lang scheme/base 2 ;; Forked from scribble-lib/scribble/private/lp.rkt 3 4 (require scribble/decode 5 scribble-enhanced/with-manual 6 scribble/struct 7 (for-syntax scheme/base 8 syntax/boundmap 9 syntax/parse 10 racket/syntax 11 racket/struct 12 syntax/srcloc 13 "../restore-comments.rkt")) 14 15 (begin-for-syntax 16 ;; maps chunk identifiers to a counter, so we can distinguish multiple uses 17 ;; of the same name 18 (define chunk-numbers (make-free-identifier-mapping)) 19 (define (get-chunk-number id) 20 (free-identifier-mapping-get chunk-numbers id (lambda () #f))) 21 (define (inc-chunk-number id) 22 (free-identifier-mapping-put! 23 chunk-numbers id 24 (+ 1 (free-identifier-mapping-get chunk-numbers id)))) 25 (define (init-chunk-number id) 26 (free-identifier-mapping-put! chunk-numbers id 2)) 27 (define repeat-chunk-numbers (make-free-identifier-mapping)) 28 (define (init-repeat-chunk-number id) 29 (free-identifier-mapping-put! repeat-chunk-numbers id 1)) 30 (define (get-repeat-chunk-number id) 31 (free-identifier-mapping-get repeat-chunk-numbers 32 id 33 (lambda () 1))) 34 (define (get+increment-repeat-chunk-number! id) 35 (let ([current (free-identifier-mapping-get repeat-chunk-numbers 36 id 37 (lambda () 1))]) 38 ;; note: due to multiple expansions, this does not increase exactly one at 39 ;; a time but instead it can skip numbers. Since this is not visible by 40 ;; the user, and just used as a token in the URL, it's okay as long as 41 ;; compiling the same file twice gives the same numbers (which is 42 ;; hopefully the case but hasn't been tested). 43 (free-identifier-mapping-put! repeat-chunk-numbers id (add1 current)) 44 current))) 45 46 (require (for-syntax "no-auto-require.rkt") 47 "chunks-toc-prefix.rkt") 48 (define-for-syntax (make-chunk-code unsyntax?) 49 (syntax-parser 50 ;; no need for more error checking, using chunk for the code will do that 51 [(_ name:id expr ...) 52 53 ;; Lift the code so that it is caught by `extract-chunks` in common.rkt 54 ;(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) 55 56 ;; Convoluted trick to allow unsyntax in chunks of code. The unsyntax 57 ;; escapes the chunk so that code can be injected at compile-time. 58 ;; The identifiers inside the escaped portion need to be available both 59 ;; for-syntax i.e. (for-meta 1) and (for-meta 0). This is because the 60 ;; underlying @racketblock expands the code at run-time, but the 61 ;; extract-chunks function in common.rkt looks at the expanded source 62 ;; code. 63 ;; For now, only #, i.e. unsyntax is supported, within @chunk. 64 ;; Later support for UNSYNTAX within @CHUNK may be added. 65 (define expand-unsyntax 66 (if unsyntax? 67 ;; New hack: 68 #'((define-syntax (macro-to-expand-unsyntax _) 69 (define a #'here) 70 (define b (syntax-local-identifier-as-binding 71 (syntax-local-introduce #'here))) 72 (define intr (make-syntax-delta-introducer b a)) 73 (syntax-local-lift-expression 74 (intr #'(quote-syntax (a-chunk ((... ...) name) 75 ((... ...) expr) ...)) 76 'flip)) 77 #'(void)) 78 (macro-to-expand-unsyntax)) 79 ;; Default (old) behaviour, does not support escaping via #, 80 (begin (syntax-local-lift-expression 81 #'(quote-syntax (a-chunk name expr ...))) 82 #f))) 83 84 (with-syntax 85 ;; Extract require forms 86 ([((for-label-mod ...) ...) 87 (if (unbox no-auto-require?) 88 #'() 89 (map (lambda (expr) 90 (syntax-case expr (require) 91 [(require mod ...) 92 (let loop ([mods (syntax->list 93 #'(mod ...))]) 94 (cond 95 [(null? mods) null] 96 [else 97 (syntax-case (car mods) 98 (for-syntax quote submod) 99 [(submod ".." . _) 100 (loop (cdr mods))] 101 [(submod "." . _) 102 (loop (cdr mods))] 103 [(quote x) 104 (loop (cdr mods))] 105 [(for-syntax x ...) 106 (append (loop (syntax->list 107 #'(x ...))) 108 (loop (cdr mods)))] 109 [x 110 (cons #'x (loop (cdr mods)))])]))] 111 [else null])) 112 (syntax->list #'(expr ...))))]) 113 #`(begin 114 #,@(if expand-unsyntax expand-unsyntax #'()) 115 #,@(if (null? (syntax-e #'(for-label-mod ... ...))) 116 #'() 117 #'((require (for-label for-label-mod ... ...))))))])) 118 119 (define-for-syntax (strip-source e) 120 (cond [(syntax? e) 121 (update-source-location 122 (datum->syntax e (strip-source (syntax-e e)) e e) 123 #:source #f)] 124 [(pair? e) (cons (strip-source (car e)) (strip-source (cdr e)))] 125 [(vector? e) (list->vector (strip-source (vector->list e)))] 126 [(prefab-struct-key e) 127 => (λ (k) (make-prefab-struct k (strip-source (struct->list e))))] 128 ;; TODO: hash tables 129 [else e])) 130 131 (define-for-syntax (prettify-chunk-name str) 132 (regexp-replace #px"^<(.*)>$" str "«\\1»")) 133 134 (define-for-syntax ((make-chunk-display racketblock unsyntax-id) stx) 135 (syntax-parse stx 136 ;; no need for more error checking, using chunk for the code will do that 137 [(_ {~optional {~seq #:button button}} 138 (original-before-expr ...) 139 original-name:id 140 name:id 141 stxn:number 142 expr ...) 143 (define n (syntax-e #'stxn)) 144 (define original-name:n (syntax-local-introduce 145 (format-id #'original-name 146 "~a:~a" 147 #'original-name 148 n))) 149 (define n-repeat (get+increment-repeat-chunk-number! 150 original-name:n)) 151 (define str (symbol->string (syntax-e #'name))) 152 (define str-display (prettify-chunk-name str)) 153 (define/with-syntax tag (format "chunk:~a:~a:~a" str n n-repeat)) 154 (define/with-syntax (rest ...) 155 ;; if the would-be-next number for this chunk name is "2", then there is 156 ;; only one chunk, whose number is "1". Otherwise, if the number is 3 or 157 ;; more, it means that the chunk with number "2" exists, so we should 158 ;; display the subscript numbers. 159 (if (let ([c (get-chunk-number #'original-name)]) 160 (and c (> c 2))) 161 #`((subscript #,(format "~a" n))) 162 #'())) 163 ;; Restore comments which have been read by the modified comment-reader 164 ;; and stashed away by read-syntax in "../lang/meta-first-line.rkt" 165 (define/with-syntax (_ . expr*+comments) 166 (restore-#%comment #'(original-before-expr ... expr ...) 167 #:replace-with 168 (λ (stx) 169 (syntax-parse stx 170 #:datum-literals (#%comment) 171 [({~and #%comment com} . rest) 172 #:with c-c (datum->syntax #'com 'code:comment #'com #'com) 173 (datum->syntax stx `(,#'c-c (,unsyntax-id . ,#'rest)) stx stx)] 174 [other 175 #'other])) 176 #:scope #'original-name)) 177 ;; The (list) here could be important, to avoid the code being 178 ;; executed multiple times in weird ways, when pre-expanding. 179 #`(list 180 (make-splice 181 (list (make-toc-element 182 #f 183 (list (elemtag '(prefixable tag) 184 (bold (italic (elemref '(prefixable tag) 185 #:underline? #f 186 #,str-display rest ...)) 187 " ::=")) 188 #,@(if (attribute button) #'{button} #'{})) 189 (list (smaller 190 (make-link-element "plainlink" 191 (decode-content 192 (list #,str-display rest ...)) 193 `(elem (prefixable 194 ,@(chunks-toc-prefix) 195 tag)))))) 196 (#,racketblock 197 . #,(strip-source #'expr*+comments)))))])) 198 199 (define-for-syntax (make-chunk chunk-code chunk-display) 200 (syntax-parser 201 ;; no need for more error checking, using chunk for the code will do that 202 [(_ {~optional {~seq #:save-as save-as:id}} 203 {~optional {~and #:display-only display-only}} 204 {~optional {~seq #:button button}} 205 {~and name:id original-before-expr} 206 expr ...) 207 #:with (btn ...) (if (attribute button) #'{#:button button} #'{}) 208 (define n (get-chunk-number (syntax-local-introduce #'name))) 209 (define/with-syntax name:n (format-id #'name "~a:~a" #'name (or n 1))) 210 211 (define/with-syntax stripped-name 212 (regexp-replace #px"^<(.*)>$" 213 (symbol->string (syntax-e #'name)) 214 "\\1")) 215 216 (when n 217 (inc-chunk-number (syntax-local-introduce #'name))) 218 219 (define/with-syntax stx-n (or n 1)) 220 (define/with-syntax stx-chunk-code chunk-code) 221 (define/with-syntax stx-chunk-display chunk-display) 222 223 #`(begin 224 #,@(if (attribute display-only) 225 #'{} 226 #`{(stx-chunk-code name 227 . #,(if preexpanding? 228 #'(expr ...) 229 #'(expr ...) 230 #;(strip-source #'(expr ...))))}) 231 #,@(if n 232 #'() 233 #'((define-syntax name (make-element-id-transformer 234 (lambda (stx) #'(chunkref name)))) 235 (define-syntax dummy (init-chunk-number #'name)))) 236 #,(if (attribute save-as) 237 #`(begin 238 #,#'(define-syntax (do-for-syntax _) 239 (init-repeat-chunk-number (quote-syntax name:n)) 240 #'(void)) 241 (do-for-syntax) 242 (define-syntax (save-as s) 243 (syntax-case s () 244 [(_) 245 (let* ([local-name (syntax-local-introduce 246 (quote-syntax name))] 247 [local-name:n (syntax-local-introduce 248 (quote-syntax name:n))] 249 [n-repeat (get-repeat-chunk-number 250 local-name:n)]) 251 (with-syntax 252 ([name-maybe-paren (if (> n-repeat 1) 253 (format-id local-name 254 "(~a)" 255 stripped-name) 256 local-name)]) 257 #'(save-as name-maybe-paren)))] 258 [(_ newname) 259 (with-syntax ([local-name 260 (syntax-local-introduce 261 (quote-syntax name))] 262 [(local-expr (... ...)) 263 (syntax-local-introduce 264 (quote-syntax #,(strip-source #'(expr ...))))]) 265 #`(stx-chunk-display 266 btn ... 267 (original-before-expr) 268 local-name 269 newname 270 stx-n 271 local-expr (... ...)))]))) 272 ;; The (list) here could be important, to avoid the code being 273 ;; executed multiple times in weird ways, when pre-expanding. 274 #`(list (stx-chunk-display btn ... 275 (original-before-expr) 276 name 277 name 278 stx-n 279 . #,(strip-source #'(expr ...))))))])) 280 281 (define-syntax chunk-code (make-chunk-code #t)) 282 (define-syntax CHUNK-code (make-chunk-code #f)) 283 (define-syntax chunk-display (make-chunk-display #'racketblock #'unsyntax)) 284 (define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK #'UNSYNTAX)) 285 (define-syntax chunk (make-chunk #'chunk-code #'chunk-display)) 286 (define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display)) 287 288 (define-syntax (chunkref stx) 289 (syntax-case stx () 290 [(_ id) 291 (identifier? #'id) 292 (with-syntax ([tag (format "chunk:~a:1:1" (syntax-e #'id))] 293 [pretty (prettify-chunk-name (format "~a" (syntax-e #'id)))]) 294 #'(elemref '(prefixable tag) #:underline? #f pretty))])) 295 296 297 (provide (all-from-out scheme/base 298 scribble-enhanced/with-manual) 299 chunk 300 CHUNK 301 chunks-toc-prefix)