suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some usual code shuffling for internal definitions.

Browse Source
This commit is contained in:
Eli Barzilay 2012-06-27 04:41:53 -04:00
parent b1c666c212
commit 1e79d368ce
1 changed files with 102 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

163
collects/meta/web/www/code.rkt
View File

@ -10,127 +10,106 @@
(define xref (load-collections-xref)) (define xref (load-collections-xref))
(define (code . strs) (define (code . strs)
(let* ([str (apply string-append strs)] (define str
[str (let ([N (- 6 (length (regexp-match-positions* "\n" str)))]) (let* ([str (string-append* strs)]
(cond [(N . > . 0) [N (- 6 (length (regexp-match-positions* "\n" str)))])
(string-append str (make-string N #\newline))] (cond [(N . > . 0) (string-append str (make-string N #\newline))]
[(N . < . 0) [(N . < . 0) (error 'code "too many lines in example: ~e" str)]
(error 'code "too many lines in example: ~e" str)] [else str])))
[else str]))] (define bstr (string->bytes/utf-8 (regexp-replace* #rx"(?m:^$)" str "\xA0")))
[bstr (string->bytes/utf-8 (regexp-replace* #rx"(?m:^$)" str "\xA0"))] (define in (open-input-bytes bstr))
[in (open-input-bytes bstr)] (define (substring* bstr start [end (bytes-length bstr)])
[tokens (bytes->string/utf-8 (subbytes bstr start end)))
(let loop ([mode #f]) (define e
(let-values ([(lexeme type data start end backup-delta mode) (parameterize ([read-accept-reader #t] [current-namespace expand-namespace])
(module-lexer in 0 mode)]) (expand (read-syntax 'prog (open-input-bytes bstr)))))
(if (eof-object? lexeme) (define ids
null (let loop ([e e])
(cons (list type (sub1 start) (sub1 end) 0)
(loop mode)))))]
[substring* (λ (bstr start [end (bytes-length bstr)])
(bytes->string/utf-8 (subbytes bstr start end)))]
[e (parameterize ([read-accept-reader #t]
[current-namespace expand-namespace])
(expand (read-syntax 'prog (open-input-bytes bstr))))]
[ids (let loop ([e e])
(cond (cond
[(and (identifier? e) [(and (identifier? e) (syntax-original? e))
(syntax-original? e)) (define pos (sub1 (syntax-position e)))
(let* ([pos (sub1 (syntax-position e))] (define b (identifier-binding e))
[b (identifier-binding e)] (define imp?
[imp? (and (list? b) (and (list? b)
(let-values ([(name base) (let-values ([(name base) (module-path-index-split (car b))])
(module-path-index-split (or name base))))
(car b))]) (define tag (and imp? (xref-binding->definition-tag xref e 0)))
(or name base)))] (list (list (cond [(not imp?) 'id]
[tag (and imp? [(not tag) 'importid]
(xref-binding->definition-tag xref e 0))]) [else (define-values [p a]
(list (list (if imp?
(if tag
(cons (if (eq? (car tag) 'form)
'linkimportform
'linkimportid)
(let-values ([(p a)
(xref-tag->path+anchor (xref-tag->path+anchor
xref tag xref tag #:external-root-url doc-root))
#:external-root-url (cons (if (eq? (car tag) 'form)
doc-root)]) 'linkimportform 'linkimportid)
(if a (format "~a#~a" p a) p))) (if a (format "~a#~a" p a) p))])
'importid) pos (+ pos (syntax-span e)) 1))]
'id)
pos (+ pos (syntax-span e)) 1)))]
[(syntax? e) [(syntax? e)
(append (loop (syntax-e e)) (append (loop (syntax-e e))
(loop (or (syntax-property e 'origin) (loop (or (syntax-property e 'origin) null))
null)) (loop (or (syntax-property e 'disappeared-use) null)))]
(loop (or (syntax-property e 'disappeared-use)
null)))]
[(pair? e) (append (loop (car e)) (loop (cdr e)))] [(pair? e) (append (loop (car e)) (loop (cdr e)))]
[else null]))] [else null])))
[link-mod (λ (mp-stx priority #:orig? [always-orig? #f]) (define (link-mod mp-stx priority #:orig? [always-orig? #f])
(if (or always-orig? (if (or always-orig? (syntax-original? mp-stx))
(syntax-original? mp-stx))
(let ([mp (syntax->datum mp-stx)]) (let ([mp (syntax->datum mp-stx)])
(let-values ([(p a) (define-values [p a]
(xref-tag->path+anchor (xref-tag->path+anchor xref `(mod-path ,(format "~s" mp))
xref #:external-root-url doc-root))
`(mod-path ,(format "~s" mp))
#:external-root-url doc-root)])
(if p (if p
(list (let ([pos (sub1 (syntax-position mp-stx))]) (list (let ([pos (sub1 (syntax-position mp-stx))])
(list (cons 'modpath (list (cons 'modpath (if a (format "~a#~a" p a) p))
(if a (format "~a#~a" p a) p)) pos (+ pos (syntax-span mp-stx)) priority)))
pos null))
(+ pos (syntax-span mp-stx)) null))
priority))) (define mods
null))) (let loop ([e e])
null))] (syntax-case e (module #%require begin)
[mods (let loop ([e e])
(syntax-case e (module require begin)
[(module name lang (mod-beg form ...)) [(module name lang (mod-beg form ...))
(apply append (append* (link-mod #'lang 2) (map loop (syntax->list #'(form ...))))]
(link-mod #'lang 2)
(map loop (syntax->list #'(form ...))))]
[(#%require spec ...) [(#%require spec ...)
(apply append (append-map (λ (spec)
(map (λ (spec)
;; Need to add support for renaming forms, etc.: ;; Need to add support for renaming forms, etc.:
(if (module-path? (syntax->datum spec)) (if (module-path? (syntax->datum spec))
(link-mod spec 2) (link-mod spec 2)
null)) null))
(syntax->list #'(spec ...))))] (syntax->list #'(spec ...)))]
[(begin form ...) [(begin form ...) (append-map loop (syntax->list #'(form ...)))]
(append-map loop (syntax->list #'(form ...)))] [else null])))
[else null]))] (define language
[language (let ([m (regexp-match #rx"^#lang ([-a-zA-Z/._+]+)" bstr)]) (let ([m (regexp-match #rx"^#lang ([-a-zA-Z/._+]+)" bstr)])
(if m (if m
(link-mod (link-mod #:orig? #t
#:orig? #t (datum->syntax #f
(datum->syntax
#f
(string->symbol (bytes->string/utf-8 (cadr m))) (string->symbol (bytes->string/utf-8 (cadr m)))
(vector 'in 1 6 7 (bytes-length (cadr m)))) (vector 'in 1 6 7 (bytes-length (cadr m))))
3) 3)
null))] null)))
[tokens (define raw-tokens
(let loop ([mode #f])
(define-values [lexeme type data start end backup-delta mode*]
(module-lexer in 0 mode))
(if (eof-object? lexeme)
null
(cons (list type (sub1 start) (sub1 end) 0) (loop mode*)))))
(define tokens
(sort (append ids mods language (sort (append ids mods language
(filter (λ (x) (not (eq? (car x) 'symbol))) (filter (λ (x) (not (eq? (car x) 'symbol)))
;; Drop #lang entry: ;; Drop #lang entry:
(cdr tokens))) (cdr raw-tokens)))
(λ (a b) (or (< (cadr a) (cadr b)) (λ (a b) (or (< (cadr a) (cadr b))
(and (= (cadr a) (cadr b)) (and (= (cadr a) (cadr b))
(> (cadddr a) (cadddr b))))))]) (> (cadddr a) (cadddr b)))))))
(let loop ([pos 0] [tokens tokens]) (let loop ([pos 0] [tokens tokens])
(cond (cond
[(null? tokens) (list (substring* bstr pos))] [(null? tokens) (list (substring* bstr pos))]
[(eq? (caar tokens) 'white-space) (loop pos (cdr tokens))] [(eq? (caar tokens) 'white-space) (loop pos (cdr tokens))]
[(= pos (cadar tokens)) [(= pos (cadar tokens))
(cons (let ([style (caar tokens)] (define style (caar tokens))
[s (substring* bstr (cadar tokens) (caddar tokens))]) (define s (substring* bstr (cadar tokens) (caddar tokens)))
(if (pair? style) (cons (if (pair? style)
(a href: (cdr style) class: @list{code@(car style)} s) (a href: (cdr style) class: @list{code@(car style)} s)
(span class: @list{code@style} s))) (span class: @list{code@style} s))
(loop (caddar tokens) (cdr tokens)))] (loop (caddar tokens) (cdr tokens)))]
[(> pos (cadar tokens)) (loop pos (cdr tokens))] [(> pos (cadar tokens)) (loop pos (cdr tokens))]
[else (cons (substring* bstr pos (cadar tokens)) [else (cons (substring* bstr pos (cadar tokens))
(loop (cadar tokens) tokens))])))) (loop (cadar tokens) tokens))])))