manual-code.rkt (16201B)
1 #lang racket/base 2 (require syntax/strip-context 3 syntax-color/module-lexer 4 syntax-color/lexer-contract 5 "../racket.rkt" 6 "../base.rkt" 7 "manual-scheme.rkt" 8 "manual-style.rkt" 9 scribble/core 10 (for-syntax racket/base 11 syntax/parse)) 12 13 (provide codeblock 14 codeblock0 15 typeset-code 16 code) 17 18 (define-for-syntax (do-codeblock stx) 19 (syntax-parse stx 20 [(_ (~seq (~or (~optional (~seq #:expand expand-expr:expr) 21 #:defaults ([expand-expr #'#f]) 22 #:name "#:expand keyword") 23 (~optional (~seq #:indent indent-expr:expr) 24 #:defaults ([indent-expr #'0]) 25 #:name "#:expand keyword") 26 (~optional (~seq #:keep-lang-line? keep-lang-line?-expr:expr) 27 #:defaults ([keep-lang-line?-expr #'#t]) 28 #:name "#:keep-lang-line? keyword") 29 (~optional (~seq #:context context-expr:expr) 30 #:name "#:context keyword") 31 (~optional (~seq #:line-numbers line-numbers:expr) 32 #:defaults ([line-numbers #'#f]) 33 #:name "#:line-numbers keyword") 34 (~optional (~seq #:line-number-sep line-number-sep:expr) 35 #:defaults ([line-number-sep #'1]) 36 #:name "#:line-number-sep keyword")) 37 ...) 38 str ...) 39 #`(typeset-code str ... 40 #:expand expand-expr 41 #:keep-lang-line? keep-lang-line?-expr 42 #:indent indent-expr 43 #:context #,(if (attribute context-expr) 44 #'context-expr 45 (or 46 (let ([v #'(str ...)]) 47 (and (pair? (syntax-e v)) 48 #`#'#,(car (syntax-e v)))) 49 #'#f)) 50 #:line-numbers line-numbers 51 #:line-number-sep line-number-sep)])) 52 53 (define-syntax (codeblock stx) #`(code-inset #,(do-codeblock stx))) 54 (define-syntax (codeblock0 stx) (do-codeblock stx)) 55 56 (define (typeset-code #:context [context #f] 57 #:expand [expand #f] 58 #:indent [indent 2] 59 #:keep-lang-line? [keep-lang-line? #t] 60 #:line-numbers [line-numbers #f] 61 #:line-number-sep [line-number-sep 1] 62 #:block? [block? #t] 63 . strs) 64 (define-values (tokens bstr) (get-tokens strs context expand)) 65 (define default-color meta-color) 66 ((if block? table (lambda (style lines) (make-element #f lines))) 67 block-color 68 ((if keep-lang-line? values cdr) ; FIXME: #lang can span lines 69 (list->lines 70 indent 71 #:line-numbers line-numbers 72 #:line-number-sep line-number-sep 73 #:block? block? 74 (let loop ([pos 0] 75 [tokens tokens]) 76 (cond 77 [(null? tokens) (split-lines default-color (substring bstr pos))] 78 [(eq? (caar tokens) 'white-space) (loop pos (cdr tokens))] 79 [(= pos (cadar tokens)) 80 (append (let ([style (caar tokens)] 81 [get-str (lambda () 82 (substring bstr (cadar tokens) (caddar tokens)))]) 83 (cond 84 [(symbol? style) 85 (let ([scribble-style 86 (case style 87 [(symbol) symbol-color] 88 [(parenthesis hash-colon-keyword) paren-color] 89 [(constant string) value-color] 90 [(comment) comment-color] 91 [else default-color])]) 92 (split-lines scribble-style (get-str)))] 93 [(procedure? style) 94 (list (style (get-str)))] 95 [else (list style)])) 96 (loop (caddar tokens) (cdr tokens)))] 97 [(> pos (cadar tokens)) 98 (loop pos (cdr tokens))] 99 [else (append 100 (split-lines default-color (substring bstr pos (cadar tokens))) 101 (loop (cadar tokens) tokens))])))))) 102 103 ;; (listof string) boolean boolean -> tokens string 104 ;; tokens is a 105 ;; (listof (list T natural natural natural)) 106 ;; T being a symbol returned as a token type from the languages lexer 107 ;; OR a function created by get-tokens 108 ;; the first number being the start position 109 ;; the second being the end position 110 ;; the third 0 if T is a symbol, and 1 or greater if its a function or element 111 ;; the tokens are sorted by the start end end positions 112 (define (get-tokens strs context expand) 113 (let* ([xstr (apply string-append strs)] 114 [bstr (regexp-replace* #rx"(?m:^$)" xstr "\xA0")] 115 [in (open-input-string bstr)]) 116 (port-count-lines! in) 117 (let* ([tokens 118 (let loop ([mode #f]) 119 (let-values ([(lexeme type data start end backup-delta mode) 120 (module-lexer in 0 mode)]) 121 (if (equal? type 'eof) 122 null 123 (cons (list type (sub1 start) (sub1 end) 0) 124 (loop (if (dont-stop? mode) 125 (dont-stop-val mode) 126 mode))))))] 127 ;; use a source that both identifies the original code 128 ;; and is unique wrt eq? as used below 129 [program-source (or context bstr)] 130 [e (parameterize ([read-accept-reader #t]) 131 ((or expand 132 (lambda (stx) 133 (if context 134 (replace-context context stx) 135 stx))) 136 (let ([p (open-input-string bstr)]) 137 (port-count-lines! p) 138 (let loop () 139 (let ([v (read-syntax program-source p)]) 140 (cond 141 [expand v] 142 [(eof-object? v) null] 143 [else (datum->syntax #f (cons v (loop)) v v)]))))))] 144 [ids (let loop ([e e]) 145 (cond 146 [(and (identifier? e) 147 (syntax-original? e) 148 (syntax-position e) 149 (eq? program-source (syntax-source e))) 150 (let ([pos (sub1 (syntax-position e))]) 151 (list (list (lambda (str) 152 (to-element (syntax-property 153 e 154 'display-string 155 str) 156 #:escapes? #f)) 157 pos 158 (+ pos (syntax-span e)) 159 1)))] 160 [(syntax? e) (append (loop (syntax-e e)) 161 (loop (or (syntax-property e 'origin) 162 null)) 163 (loop (or (syntax-property e 'disappeared-use) 164 null)))] 165 [(pair? e) (append (loop (car e)) (loop (cdr e)))] 166 [else null]))] 167 [link-mod (lambda (mp-stx priority #:orig? [always-orig? #f]) 168 (if (or always-orig? 169 (syntax-original? mp-stx)) 170 (let ([mp (syntax->datum mp-stx)] 171 [pos (sub1 (syntax-position mp-stx))]) 172 (list (list (racketmodname #,mp) 173 pos 174 (+ pos (syntax-span mp-stx)) 175 priority))) 176 null))] 177 ;; This makes sense when `expand' actually expands, and 178 ;; probably not otherwise: 179 [mods (let loop ([e e]) 180 (syntax-case e (module #%require begin) 181 [(module name lang (mod-beg form ...)) 182 (apply append 183 (link-mod #'lang 2) 184 (map loop (syntax->list #'(form ...))))] 185 [(#%require spec ...) 186 (apply append 187 (map (lambda (spec) 188 ;; Need to add support for renaming forms, etc.: 189 (if (module-path? (syntax->datum spec)) 190 (link-mod spec 2) 191 null)) 192 (syntax->list #'(spec ...))))] 193 [(begin form ...) 194 (apply append 195 (map loop (syntax->list #'(form ...))))] 196 [else null]))] 197 [has-hash-lang? (regexp-match? #rx"^#lang " bstr)] 198 [hash-lang (if has-hash-lang? 199 (list (list (hash-lang) 200 0 201 5 202 1) 203 (list 'white-space 5 6 0)) 204 null)] 205 [language (if has-hash-lang? 206 (let ([m (regexp-match #rx"^#lang ([-0-9a-zA-Z/._+]+)" bstr)]) 207 (if m 208 (link-mod 209 #:orig? #t 210 (datum->syntax #f 211 (string->symbol (cadr m)) 212 (vector 'in 1 6 7 (string-length (cadr m)))) 213 3) 214 null)) 215 null)] 216 [tokens (sort (append ids 217 mods 218 hash-lang 219 language 220 (filter (lambda (x) (not (eq? (car x) 'symbol))) 221 (if has-hash-lang? 222 ;; Drop #lang entry: 223 (cdr tokens) 224 tokens))) 225 (lambda (a b) 226 (or (< (cadr a) (cadr b)) 227 (and (= (cadr a) (cadr b)) 228 (> (cadddr a) (cadddr b))))))]) 229 (values tokens bstr)))) 230 231 (define (typeset-code-line context expand lang-line . strs) 232 (typeset-code 233 #:context context 234 #:expand expand 235 #:keep-lang-line? (not lang-line) 236 #:block? #f 237 #:indent 0 238 (let ([s (regexp-replace* #px"(?:\\s*(?:\r|\n|\r\n)\\s*)+" (apply string-append strs) " ")]) 239 (if lang-line 240 (string-append "#lang " lang-line "\n" s) 241 s)))) 242 243 (define-syntax (code stx) 244 (syntax-parse stx 245 [(_ (~seq (~or (~optional (~seq #:expand expand-expr:expr) 246 #:defaults ([expand-expr #'#f]) 247 #:name "#:expand keyword") 248 (~optional (~seq #:context context-expr:expr) 249 #:name "#:context keyword") 250 (~optional (~seq #:lang lang-line-expr:expr) 251 #:defaults ([lang-line-expr #'#f]) 252 #:name "#:lang-line keyword")) 253 ...) 254 str ...) 255 #`(typeset-code-line #,(if (attribute context-expr) 256 #'context-expr 257 (or 258 (let ([v #'(str ...)]) 259 (and (pair? (syntax-e v)) 260 #`#'#,(car (syntax-e v)))) 261 #'#f)) 262 expand-expr 263 lang-line-expr 264 str ...)])) 265 266 (define (split-lines style s) 267 (cond 268 [(regexp-match-positions #rx"(?:\r\n|\r|\n)" s) 269 => (lambda (m) 270 (append (split-lines style (substring s 0 (caar m))) 271 (list 'newline) 272 (split-lines style (substring s (cdar m)))))] 273 [(regexp-match-positions #rx" +" s) 274 => (lambda (m) 275 (append (split-lines style (substring s 0 (caar m))) 276 (list (hspace (- (cdar m) (caar m)))) 277 (split-lines style (substring s (cdar m)))))] 278 [else (list (element style s))])) 279 280 (define omitable (make-style #f '(omitable))) 281 282 (define (list->lines indent-amt l 283 #:line-numbers line-numbers 284 #:line-number-sep line-number-sep 285 #:block? block?) 286 (define indent-elem (if (zero? indent-amt) 287 "" 288 (hspace indent-amt))) 289 ;(list of any) delim -> (list of (list of any)) 290 (define (break-list lst delim) 291 (let loop ([l lst] [n null] [c null]) 292 (cond 293 [(null? l) (reverse (if (null? c) n (cons (reverse c) n)))] 294 [(eq? delim (car l)) (loop (cdr l) (cons (reverse c) n) null)] 295 [else (loop (cdr l) n (cons (car l) c) )]))) 296 297 (define lines (break-list l 'newline)) 298 (define line-cnt (length lines)) 299 (define line-cntl (string-length (format "~a" (+ line-cnt (or line-numbers 0))))) 300 301 (define (prepend-line-number n r) 302 (define ln (format "~a" n)) 303 (define lnl (string-length ln)) 304 (define diff (- line-cntl lnl)) 305 (define l1 (list (tt ln) (hspace line-number-sep))) 306 (cons (make-element 'smaller 307 (make-element 'smaller 308 (if (not (zero? diff)) 309 (cons (hspace diff) l1) 310 l1))) 311 r)) 312 313 (define (make-line accum-line line-number) 314 (define rest (cons indent-elem accum-line)) 315 (list ((if block? paragraph (lambda (s e) e)) 316 omitable 317 (if line-numbers 318 (prepend-line-number line-number rest) 319 rest)))) 320 321 (for/list ([l (break-list l 'newline)] 322 [i (in-naturals (or line-numbers 1))]) 323 (make-line l i))) 324 325 326 ;; ---------------------------------------- 327 328 (module+ test 329 (require racket/list 330 racket/match 331 rackunit) 332 333 (define (tokens strs) 334 (define-values (toks _) (get-tokens strs #f #f)) 335 (for/list ([tok (in-list toks)]) 336 (match tok 337 [(list _ start end (or 1 2 3)) 338 (list 'function start end 1)] ; this looses information 339 [_ tok]))) 340 341 (define (make-test-result lst) 342 (define-values (res _) 343 (for/fold ([result null] [count 12]) 344 ([p lst]) 345 (define next (+ count (second p))) 346 (define r (if (eq? (first p) 'function) 1 0)) 347 (values 348 (cons (list (first p) count next r) result) 349 next))) 350 (list* `(function 0 5 1) `(white-space 5 6 0) `(function 6 12 1) `(function 6 12 1) 351 (reverse res))) 352 353 (check-equal? 354 (tokens (list "#lang racket\n1")) 355 `((function 0 5 1) (white-space 5 6 0) ;"#lang " 356 (function 6 12 1) (function 6 12 1) (white-space 12 13 0) ;"racket\n" 357 (constant 13 14 0))) ; "1" 358 (check-equal? 359 (tokens (list "#lang racket\n" "(+ 1 2)")) 360 (make-test-result 361 '((white-space 1) 362 (parenthesis 1) (function 1) 363 (white-space 1) (constant 1) (white-space 1) (constant 1) 364 (parenthesis 1)))) 365 (check-equal? 366 (tokens (list "#lang racket\n(apply x (list y))")) 367 (make-test-result 368 '((white-space 1) 369 (parenthesis 1) 370 (function 5) (white-space 1);apply 371 (function 1) (white-space 1);x 372 (parenthesis 1) 373 (function 4) (white-space 1) (function 1);list y 374 (parenthesis 1) 375 (parenthesis 1)))))