Langify scribble modules
This commit is contained in:
Jack Firth
Matthew Flatt
parent
fb7106bc50
commit
3c62d4cd5d
|
|
@ -1,121 +1,122 @@
|
||||||
(module bnf racket
|
#lang racket
|
||||||
(require scribble/decode
|
|
||||||
(except-in scribble/struct
|
|
||||||
element?)
|
|
||||||
(only-in scribble/core
|
|
||||||
content?
|
|
||||||
element?
|
|
||||||
make-style
|
|
||||||
make-table-columns)
|
|
||||||
)
|
|
||||||
|
|
||||||
(provide (contract-out
|
(require scribble/decode
|
||||||
[BNF (-> (cons/c (or/c block? content?)
|
(except-in scribble/struct
|
||||||
(non-empty-listof (or/c block? content?)))
|
element?)
|
||||||
...
|
(only-in scribble/core
|
||||||
table?)]
|
content?
|
||||||
[BNF-etc element?]
|
element?
|
||||||
;; operate on content
|
make-style
|
||||||
[BNF-seq (-> content? ...
|
make-table-columns)
|
||||||
(or/c element? ""))]
|
)
|
||||||
[BNF-seq-lines (-> (listof content?) ...
|
|
||||||
block?)]
|
(provide (contract-out
|
||||||
[BNF-alt (-> content? ...
|
[BNF (-> (cons/c (or/c block? content?)
|
||||||
element?)]
|
(non-empty-listof (or/c block? content?)))
|
||||||
[BNF-alt/close (-> content? ...
|
...
|
||||||
element?)]
|
table?)]
|
||||||
;; operate on pre-content
|
[BNF-etc element?]
|
||||||
[BNF-group (-> pre-content? ...
|
;; operate on content
|
||||||
element?)]
|
[BNF-seq (-> content? ...
|
||||||
[nonterm (-> pre-content? ...
|
(or/c element? ""))]
|
||||||
element?)]
|
[BNF-seq-lines (-> (listof content?) ...
|
||||||
[optional (-> pre-content? ...
|
block?)]
|
||||||
element?)]
|
[BNF-alt (-> content? ...
|
||||||
[kleenestar (-> pre-content? ...
|
element?)]
|
||||||
element?)]
|
[BNF-alt/close (-> content? ...
|
||||||
[kleeneplus (-> pre-content? ...
|
|
||||||
element?)]
|
|
||||||
[kleenerange (-> any/c any/c pre-content? ...
|
|
||||||
element?)]
|
element?)]
|
||||||
))
|
;; operate on pre-content
|
||||||
|
[BNF-group (-> pre-content? ...
|
||||||
|
element?)]
|
||||||
(define spacer (make-element 'hspace (list " ")))
|
[nonterm (-> pre-content? ...
|
||||||
(define equals (make-element 'tt (list spacer "::=" spacer)))
|
element?)]
|
||||||
(define alt (make-element 'tt (list spacer spacer "|" spacer spacer)))
|
[optional (-> pre-content? ...
|
||||||
|
element?)]
|
||||||
(define (as-flow i) (make-flow (list (if (block? i)
|
[kleenestar (-> pre-content? ...
|
||||||
i
|
element?)]
|
||||||
(make-paragraph (list i))))))
|
[kleeneplus (-> pre-content? ...
|
||||||
|
element?)]
|
||||||
|
[kleenerange (-> any/c any/c pre-content? ...
|
||||||
|
element?)]
|
||||||
|
))
|
||||||
|
|
||||||
|
|
||||||
(define baseline (make-style #f '(baseline)))
|
(define spacer (make-element 'hspace (list " ")))
|
||||||
|
(define equals (make-element 'tt (list spacer "::=" spacer)))
|
||||||
|
(define alt (make-element 'tt (list spacer spacer "|" spacer spacer)))
|
||||||
|
|
||||||
(define (BNF . defns)
|
(define (as-flow i) (make-flow (list (if (block? i)
|
||||||
(make-table
|
i
|
||||||
(make-style #f
|
(make-paragraph (list i))))))
|
||||||
(list
|
|
||||||
(make-table-columns
|
|
||||||
(list baseline baseline baseline baseline))))
|
|
||||||
(apply
|
|
||||||
append
|
|
||||||
(map (match-lambda
|
|
||||||
[(cons lhs (cons rhs0 more-rhs))
|
|
||||||
(cons
|
|
||||||
(list (as-flow spacer) (as-flow lhs) (as-flow equals) (as-flow rhs0))
|
|
||||||
(map (lambda (i)
|
|
||||||
(list (as-flow spacer) (as-flow " ") (as-flow alt) (as-flow i)))
|
|
||||||
more-rhs))])
|
|
||||||
defns))))
|
|
||||||
|
|
||||||
;; interleave : (listof content?) element? -> element?
|
|
||||||
(define (interleave l spacer)
|
|
||||||
(make-element #f (cons (car l)
|
|
||||||
(apply append
|
|
||||||
(map (lambda (i)
|
|
||||||
(list spacer i))
|
|
||||||
(cdr l))))))
|
|
||||||
|
|
||||||
(define (BNF-seq . l)
|
(define baseline (make-style #f '(baseline)))
|
||||||
(if (null? l)
|
|
||||||
""
|
|
||||||
(interleave l spacer)))
|
|
||||||
|
|
||||||
(define (BNF-seq-lines . l)
|
(define (BNF . defns)
|
||||||
(make-table #f (map (lambda (row) (list (as-flow (apply BNF-seq row))))
|
(make-table
|
||||||
l)))
|
(make-style #f
|
||||||
|
(list
|
||||||
|
(make-table-columns
|
||||||
|
(list baseline baseline baseline baseline))))
|
||||||
|
(apply
|
||||||
|
append
|
||||||
|
(map (match-lambda
|
||||||
|
[(cons lhs (cons rhs0 more-rhs))
|
||||||
|
(cons
|
||||||
|
(list (as-flow spacer) (as-flow lhs) (as-flow equals) (as-flow rhs0))
|
||||||
|
(map (lambda (i)
|
||||||
|
(list (as-flow spacer) (as-flow " ") (as-flow alt) (as-flow i)))
|
||||||
|
more-rhs))])
|
||||||
|
defns))))
|
||||||
|
|
||||||
(define (BNF-alt . l)
|
;; interleave : (listof content?) element? -> element?
|
||||||
(interleave l alt))
|
(define (interleave l spacer)
|
||||||
|
(make-element #f (cons (car l)
|
||||||
|
(apply append
|
||||||
|
(map (lambda (i)
|
||||||
|
(list spacer i))
|
||||||
|
(cdr l))))))
|
||||||
|
|
||||||
(define (BNF-alt/close . l)
|
(define (BNF-seq . l)
|
||||||
(interleave l (make-element 'roman " | ")))
|
(if (null? l)
|
||||||
|
""
|
||||||
|
(interleave l spacer)))
|
||||||
|
|
||||||
(define BNF-etc (make-element 'roman "..."))
|
(define (BNF-seq-lines . l)
|
||||||
|
(make-table #f (map (lambda (row) (list (as-flow (apply BNF-seq row))))
|
||||||
|
l)))
|
||||||
|
|
||||||
(define (nonterm . s)
|
(define (BNF-alt . l)
|
||||||
(make-element 'roman (append (list 'lang)
|
(interleave l alt))
|
||||||
(list (make-element 'italic (decode-content s)))
|
|
||||||
(list 'rang))))
|
|
||||||
|
|
||||||
(define (optional . s)
|
(define (BNF-alt/close . l)
|
||||||
(make-element #f (append (list (make-element 'roman "["))
|
(interleave l (make-element 'roman " | ")))
|
||||||
(decode-content s)
|
|
||||||
(list (make-element 'roman "]")))))
|
|
||||||
|
|
||||||
(define (BNF-group . s)
|
(define BNF-etc (make-element 'roman "..."))
|
||||||
(make-element #f (append (list (make-element 'roman "{"))
|
|
||||||
(list (apply BNF-seq (decode-content s)))
|
|
||||||
(list (make-element 'roman "}")))))
|
|
||||||
|
|
||||||
(define (kleenestar . s)
|
(define (nonterm . s)
|
||||||
(make-element #f (append (decode-content s) (list (make-element 'roman "*")))))
|
(make-element 'roman (append (list 'lang)
|
||||||
|
(list (make-element 'italic (decode-content s)))
|
||||||
|
(list 'rang))))
|
||||||
|
|
||||||
(define (kleeneplus . s)
|
(define (optional . s)
|
||||||
(make-element #f (append (decode-content s) (list (make-element 'superscript (list "+"))))))
|
(make-element #f (append (list (make-element 'roman "["))
|
||||||
|
(decode-content s)
|
||||||
|
(list (make-element 'roman "]")))))
|
||||||
|
|
||||||
(define (kleenerange a b . s)
|
(define (BNF-group . s)
|
||||||
(make-element #f (append (decode-content s)
|
(make-element #f (append (list (make-element 'roman "{"))
|
||||||
(list (make-element 'roman
|
(list (apply BNF-seq (decode-content s)))
|
||||||
(make-element 'superscript
|
(list (make-element 'roman "}")))))
|
||||||
(list (format "{~a,~a}" a b)))))))))
|
|
||||||
|
(define (kleenestar . s)
|
||||||
|
(make-element #f (append (decode-content s) (list (make-element 'roman "*")))))
|
||||||
|
|
||||||
|
(define (kleeneplus . s)
|
||||||
|
(make-element #f (append (decode-content s) (list (make-element 'superscript (list "+"))))))
|
||||||
|
|
||||||
|
(define (kleenerange a b . s)
|
||||||
|
(make-element #f (append (decode-content s)
|
||||||
|
(list (make-element 'roman
|
||||||
|
(make-element 'superscript
|
||||||
|
(list (format "{~a,~a}" a b))))))))
|
||||||
|
|
|
||||||
|
|
@ -1,83 +1,84 @@
|
||||||
(module comment-reader scheme/base
|
#lang scheme/base
|
||||||
(require (only-in racket/port peeking-input-port))
|
|
||||||
|
|
||||||
(provide (rename-out [*read read]
|
(require (only-in racket/port peeking-input-port))
|
||||||
[*read-syntax read-syntax])
|
|
||||||
make-comment-readtable)
|
|
||||||
|
|
||||||
(define unsyntaxer (make-parameter 'unsyntax))
|
(provide (rename-out [*read read]
|
||||||
|
[*read-syntax read-syntax])
|
||||||
|
make-comment-readtable)
|
||||||
|
|
||||||
(define (*read [inp (current-input-port)])
|
(define unsyntaxer (make-parameter 'unsyntax))
|
||||||
(parameterize ([unsyntaxer (read-unsyntaxer inp)]
|
|
||||||
[current-readtable (make-comment-readtable)])
|
|
||||||
(read/recursive inp)))
|
|
||||||
|
|
||||||
(define (*read-syntax src [port (current-input-port)])
|
(define (*read [inp (current-input-port)])
|
||||||
(parameterize ([unsyntaxer (read-unsyntaxer port)]
|
(parameterize ([unsyntaxer (read-unsyntaxer inp)]
|
||||||
[current-readtable (make-comment-readtable)])
|
[current-readtable (make-comment-readtable)])
|
||||||
(read-syntax/recursive src port)))
|
(read/recursive inp)))
|
||||||
|
|
||||||
|
(define (*read-syntax src [port (current-input-port)])
|
||||||
|
(parameterize ([unsyntaxer (read-unsyntaxer port)]
|
||||||
|
[current-readtable (make-comment-readtable)])
|
||||||
|
(read-syntax/recursive src port)))
|
||||||
|
|
||||||
(define (read-unsyntaxer port)
|
(define (read-unsyntaxer port)
|
||||||
(let ([p (peeking-input-port port)])
|
(let ([p (peeking-input-port port)])
|
||||||
(if (eq? (read p) '#:escape-id)
|
(if (eq? (read p) '#:escape-id)
|
||||||
(begin (read port) (read port))
|
(begin (read port) (read port))
|
||||||
'unsyntax)))
|
'unsyntax)))
|
||||||
|
|
||||||
(define (make-comment-readtable #:readtable [rt (current-readtable)])
|
(define (make-comment-readtable #:readtable [rt (current-readtable)])
|
||||||
(make-readtable rt
|
(make-readtable rt
|
||||||
#\; 'terminating-macro
|
#\; 'terminating-macro
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(char port)
|
[(char port)
|
||||||
(do-comment port (lambda () (read/recursive port #\@)))]
|
(do-comment port (lambda () (read/recursive port #\@)))]
|
||||||
[(char port src line col pos)
|
[(char port src line col pos)
|
||||||
(let ([v (do-comment port (lambda () (read-syntax/recursive src port #\@)))])
|
(let ([v (do-comment port (lambda () (read-syntax/recursive src port #\@)))])
|
||||||
(let-values ([(eline ecol epos) (port-next-location port)])
|
(let-values ([(eline ecol epos) (port-next-location port)])
|
||||||
(datum->syntax
|
(datum->syntax
|
||||||
#f
|
#f
|
||||||
v
|
v
|
||||||
(list src line col pos (and pos epos (- epos pos))))))])))
|
(list src line col pos (and pos epos (- epos pos))))))])))
|
||||||
|
|
||||||
(define (do-comment port recur)
|
(define (do-comment port recur)
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(when (equal? #\; (peek-char port))
|
(when (equal? #\; (peek-char port))
|
||||||
(read-char port)
|
(read-char port)
|
||||||
(loop)))
|
(loop)))
|
||||||
(when (equal? #\space (peek-char port))
|
(when (equal? #\space (peek-char port))
|
||||||
(read-char port))
|
(read-char port))
|
||||||
`(code:comment
|
`(code:comment
|
||||||
(,(unsyntaxer)
|
(,(unsyntaxer)
|
||||||
(t
|
(t
|
||||||
,@(append-strings
|
,@(append-strings
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(let ([c (read-char port)])
|
(let ([c (read-char port)])
|
||||||
(cond
|
(cond
|
||||||
[(or (eof-object? c)
|
[(or (eof-object? c)
|
||||||
(char=? c #\newline))
|
(char=? c #\newline))
|
||||||
null]
|
null]
|
||||||
[(char=? c #\@)
|
[(char=? c #\@)
|
||||||
(cons (recur) (loop))]
|
(cons (recur) (loop))]
|
||||||
[else
|
[else
|
||||||
(cons (string c)
|
(cons (string c)
|
||||||
(loop))]))))))))
|
(loop))]))))))))
|
||||||
|
|
||||||
(define (append-strings l)
|
(define (append-strings l)
|
||||||
(let loop ([l l][s null])
|
(let loop ([l l][s null])
|
||||||
(cond
|
(cond
|
||||||
[(null? l) (if (null? s)
|
[(null? l) (if (null? s)
|
||||||
null
|
null
|
||||||
(preserve-space (apply string-append (reverse s))))]
|
(preserve-space (apply string-append (reverse s))))]
|
||||||
[(string? (car l))
|
[(string? (car l))
|
||||||
(loop (cdr l) (cons (car l) s))]
|
(loop (cdr l) (cons (car l) s))]
|
||||||
[else
|
[else
|
||||||
(append (loop null s)
|
(append (loop null s)
|
||||||
(cons
|
(cons
|
||||||
(car l)
|
(car l)
|
||||||
(loop (cdr l) null)))])))
|
(loop (cdr l) null)))])))
|
||||||
|
|
||||||
(define (preserve-space s)
|
(define (preserve-space s)
|
||||||
(let ([m (regexp-match-positions #rx" +" s)])
|
(let ([m (regexp-match-positions #rx" +" s)])
|
||||||
(if m
|
(if m
|
||||||
(append (preserve-space (substring s 0 (caar m)))
|
(append (preserve-space (substring s 0 (caar m)))
|
||||||
(list `(hspace ,(- (cdar m) (caar m))))
|
(list `(hspace ,(- (cdar m) (caar m))))
|
||||||
(preserve-space (substring s (cdar m))))
|
(preserve-space (substring s (cdar m))))
|
||||||
(list s)))))
|
(list s))))
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,5 @@
|
||||||
|
#lang mzscheme
|
||||||
|
|
||||||
(module config mzscheme
|
(provide value-color)
|
||||||
|
|
||||||
(provide value-color)
|
(define value-color "schemevalue")
|
||||||
|
|
||||||
(define value-color "schemevalue"))
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,142 +1,143 @@
|
||||||
(module search racket/base
|
#lang racket/base
|
||||||
(require "struct.rkt"
|
|
||||||
"basic.rkt"
|
|
||||||
syntax/modcode)
|
|
||||||
|
|
||||||
(provide find-racket-tag
|
(require "struct.rkt"
|
||||||
(rename-out [find-racket-tag find-scheme-tag]))
|
"basic.rkt"
|
||||||
|
syntax/modcode)
|
||||||
|
|
||||||
(define module-info-cache (make-hasheq))
|
(provide find-racket-tag
|
||||||
|
(rename-out [find-racket-tag find-scheme-tag]))
|
||||||
|
|
||||||
(define (module-path-index-rejoin mpi rel-to)
|
(define module-info-cache (make-hasheq))
|
||||||
(let-values ([(name base) (module-path-index-split mpi)])
|
|
||||||
(cond
|
|
||||||
[(not name) rel-to]
|
|
||||||
[(not base) mpi]
|
|
||||||
[else
|
|
||||||
(module-path-index-join name
|
|
||||||
(module-path-index-rejoin base rel-to))])))
|
|
||||||
|
|
||||||
(define (try thunk fail-thunk)
|
(define (module-path-index-rejoin mpi rel-to)
|
||||||
(with-handlers* ([exn:fail? (lambda (exn) (fail-thunk))])
|
(let-values ([(name base) (module-path-index-split mpi)])
|
||||||
(thunk)))
|
(cond
|
||||||
|
[(not name) rel-to]
|
||||||
|
[(not base) mpi]
|
||||||
|
[else
|
||||||
|
(module-path-index-join name
|
||||||
|
(module-path-index-rejoin base rel-to))])))
|
||||||
|
|
||||||
(define (find-racket-tag part ri stx/binding phase-level)
|
(define (try thunk fail-thunk)
|
||||||
;; The phase-level argument is used only when `stx/binding'
|
(with-handlers* ([exn:fail? (lambda (exn) (fail-thunk))])
|
||||||
;; is an identifier.
|
(thunk)))
|
||||||
;;
|
|
||||||
;; Note: documentation keys currently don't distinguish different
|
(define (find-racket-tag part ri stx/binding phase-level)
|
||||||
;; phase definitions of an identifier from a source module.
|
;; The phase-level argument is used only when `stx/binding'
|
||||||
;; That is, there's no way to document (define x ....) differently
|
;; is an identifier.
|
||||||
;; from (define-for-syntax x ...). This isn't a problem in practice,
|
;;
|
||||||
;; because no one uses the same name for different-phase exported
|
;; Note: documentation keys currently don't distinguish different
|
||||||
;; bindings.
|
;; phase definitions of an identifier from a source module.
|
||||||
;;
|
;; That is, there's no way to document (define x ....) differently
|
||||||
;; Formerly, we assumed that bindings are defined as originating from some
|
;; from (define-for-syntax x ...). This isn't a problem in practice,
|
||||||
;; module at phase 0. [Maybe it's defined at phase 1 and re-exported
|
;; because no one uses the same name for different-phase exported
|
||||||
;; later for phase 0 (after a require-for-template), in which case the
|
;; bindings.
|
||||||
;; re-exporting module is the one we find.] That assumption has been
|
;;
|
||||||
;; lifted, however; search for "GONE" below.
|
;; Formerly, we assumed that bindings are defined as originating from some
|
||||||
(let ([b (cond
|
;; module at phase 0. [Maybe it's defined at phase 1 and re-exported
|
||||||
[(identifier? stx/binding)
|
;; later for phase 0 (after a require-for-template), in which case the
|
||||||
(identifier-binding stx/binding phase-level)]
|
;; re-exporting module is the one we find.] That assumption has been
|
||||||
[(and (list? stx/binding)
|
;; lifted, however; search for "GONE" below.
|
||||||
(= 7 (length stx/binding)))
|
(let ([b (cond
|
||||||
stx/binding]
|
[(identifier? stx/binding)
|
||||||
[else
|
(identifier-binding stx/binding phase-level)]
|
||||||
(and (not (symbol? (car stx/binding)))
|
[(and (list? stx/binding)
|
||||||
(list #f
|
(= 7 (length stx/binding)))
|
||||||
(cadr stx/binding)
|
stx/binding]
|
||||||
(car stx/binding)
|
[else
|
||||||
(cadr stx/binding)
|
(and (not (symbol? (car stx/binding)))
|
||||||
(if (= 2 (length stx/binding))
|
(list #f
|
||||||
0
|
(cadr stx/binding)
|
||||||
(caddr stx/binding))
|
(car stx/binding)
|
||||||
(if (= 2 (length stx/binding))
|
(cadr stx/binding)
|
||||||
0
|
(if (= 2 (length stx/binding))
|
||||||
(cadddr stx/binding))
|
0
|
||||||
(if (= 2 (length stx/binding))
|
(caddr stx/binding))
|
||||||
0
|
(if (= 2 (length stx/binding))
|
||||||
(cadddr (cdr stx/binding)))))])])
|
0
|
||||||
(and
|
(cadddr stx/binding))
|
||||||
(pair? b)
|
(if (= 2 (length stx/binding))
|
||||||
(let ([seen (make-hash)]
|
0
|
||||||
[search-key #f])
|
(cadddr (cdr stx/binding)))))])])
|
||||||
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
|
(and
|
||||||
[rqueue null]
|
(pair? b)
|
||||||
[need-result? #t])
|
(let ([seen (make-hash)]
|
||||||
(cond
|
[search-key #f])
|
||||||
[(null? queue)
|
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
|
||||||
(if (null? rqueue)
|
[rqueue null]
|
||||||
;; Not documented
|
[need-result? #t])
|
||||||
#f
|
(cond
|
||||||
(loop (reverse rqueue) null need-result?))]
|
[(null? queue)
|
||||||
[else
|
(if (null? rqueue)
|
||||||
(let ([mod (list-ref (car queue) 0)]
|
;; Not documented
|
||||||
[id (list-ref (car queue) 1)]
|
#f
|
||||||
[defn-phase (list-ref (car queue) 2)]
|
(loop (reverse rqueue) null need-result?))]
|
||||||
[import-phase (list-ref (car queue) 3)]
|
[else
|
||||||
[export-phase (list-ref (car queue) 4)]
|
(let ([mod (list-ref (car queue) 0)]
|
||||||
[queue (cdr queue)])
|
[id (list-ref (car queue) 1)]
|
||||||
(let* ([rmp (module-path-index-resolve mod)]
|
[defn-phase (list-ref (car queue) 2)]
|
||||||
[eb (and ;; GONE: (equal? 0 export-phase) ;; look for the phase-0 export; good idea?
|
[import-phase (list-ref (car queue) 3)]
|
||||||
(list (module-path-index->taglet mod)
|
[export-phase (list-ref (car queue) 4)]
|
||||||
id))])
|
[queue (cdr queue)])
|
||||||
(when (and eb
|
(let* ([rmp (module-path-index-resolve mod)]
|
||||||
(not search-key))
|
[eb (and ;; GONE: (equal? 0 export-phase) ;; look for the phase-0 export; good idea?
|
||||||
(set! search-key eb))
|
(list (module-path-index->taglet mod)
|
||||||
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
|
id))])
|
||||||
(let* ([here-result
|
(when (and eb
|
||||||
(and need-result?
|
(not search-key))
|
||||||
v
|
(set! search-key eb))
|
||||||
(let ([v (resolve-get/tentative part ri `(form ,eb))])
|
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
|
||||||
(or (and v `(form ,eb))
|
(let* ([here-result
|
||||||
`(def ,eb))))]
|
(and need-result?
|
||||||
[need-result? (and need-result? (not here-result))]
|
v
|
||||||
[rmp-name (resolved-module-path-name rmp)])
|
(let ([v (resolve-get/tentative part ri `(form ,eb))])
|
||||||
;; Even if we've found `here-result', look deeper so that we have
|
(or (and v `(form ,eb))
|
||||||
;; consistent `dep' results.
|
`(def ,eb))))]
|
||||||
(let ([nest-result
|
[need-result? (and need-result? (not here-result))]
|
||||||
;; Maybe it's re-exported from this module...
|
[rmp-name (resolved-module-path-name rmp)])
|
||||||
;; Try a shortcut:
|
;; Even if we've found `here-result', look deeper so that we have
|
||||||
(if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
|
;; consistent `dep' results.
|
||||||
;; Not defined through this path, so keep looking
|
(let ([nest-result
|
||||||
(loop queue rqueue need-result?)
|
;; Maybe it's re-exported from this module...
|
||||||
;; Check parents, if we can get the source:
|
;; Try a shortcut:
|
||||||
(if (and (or (path? rmp-name)
|
(if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
|
||||||
(and (list? rmp-name)
|
;; Not defined through this path, so keep looking
|
||||||
(path? (car rmp-name))))
|
(loop queue rqueue need-result?)
|
||||||
(not (hash-ref seen (cons export-phase rmp) #f)))
|
;; Check parents, if we can get the source:
|
||||||
(let ([exports
|
(if (and (or (path? rmp-name)
|
||||||
(hash-ref
|
(and (list? rmp-name)
|
||||||
module-info-cache
|
(path? (car rmp-name))))
|
||||||
rmp
|
(not (hash-ref seen (cons export-phase rmp) #f)))
|
||||||
(lambda ()
|
(let ([exports
|
||||||
(let-values ([(valss stxess)
|
(hash-ref
|
||||||
(try
|
module-info-cache
|
||||||
(lambda ()
|
rmp
|
||||||
;; First, try using bytecode:
|
(lambda ()
|
||||||
(module-compiled-exports
|
(let-values ([(valss stxess)
|
||||||
(get-module-code (if (list? rmp-name)
|
(try
|
||||||
(car rmp-name)
|
(lambda ()
|
||||||
rmp-name)
|
;; First, try using bytecode:
|
||||||
#:submodule-path (if (list? rmp-name)
|
(module-compiled-exports
|
||||||
(cdr rmp-name)
|
(get-module-code (if (list? rmp-name)
|
||||||
'())
|
(car rmp-name)
|
||||||
#:choose (lambda (src zo so) 'zo))))
|
rmp-name)
|
||||||
(lambda ()
|
#:submodule-path (if (list? rmp-name)
|
||||||
(try
|
(cdr rmp-name)
|
||||||
(lambda ()
|
'())
|
||||||
;; Bytecode not available. Declaration in the
|
#:choose (lambda (src zo so) 'zo))))
|
||||||
;; current namespace?
|
(lambda ()
|
||||||
(module->exports rmp))
|
(try
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(values null null)))))])
|
;; Bytecode not available. Declaration in the
|
||||||
(let ([t
|
;; current namespace?
|
||||||
;; Merge the two association lists:
|
(module->exports rmp))
|
||||||
(let loop ([base valss]
|
(lambda ()
|
||||||
[stxess stxess])
|
(values null null)))))])
|
||||||
(cond
|
(let ([t
|
||||||
|
;; Merge the two association lists:
|
||||||
|
(let loop ([base valss]
|
||||||
|
[stxess stxess])
|
||||||
|
(cond
|
||||||
[(null? stxess) base]
|
[(null? stxess) base]
|
||||||
[(assoc (caar stxess) base)
|
[(assoc (caar stxess) base)
|
||||||
=> (lambda (l)
|
=> (lambda (l)
|
||||||
|
|
@ -148,40 +149,40 @@
|
||||||
[else (loop (cons (car stxess)
|
[else (loop (cons (car stxess)
|
||||||
base)
|
base)
|
||||||
(cdr stxess))]))])
|
(cdr stxess))]))])
|
||||||
(hash-set! module-info-cache rmp t)
|
(hash-set! module-info-cache rmp t)
|
||||||
t))))])
|
t))))])
|
||||||
(hash-set! seen (cons export-phase rmp) #t)
|
(hash-set! seen (cons export-phase rmp) #t)
|
||||||
(let ([a (assq id (let ([a (assoc export-phase exports)])
|
(let ([a (assq id (let ([a (assoc export-phase exports)])
|
||||||
(if a
|
(if a
|
||||||
(cdr a)
|
(cdr a)
|
||||||
null)))])
|
null)))])
|
||||||
(if a
|
(if a
|
||||||
(loop queue
|
(loop queue
|
||||||
(append (map (lambda (m)
|
(append (map (lambda (m)
|
||||||
(if (pair? m)
|
(if (pair? m)
|
||||||
(list (module-path-index-rejoin (car m) mod)
|
(list (module-path-index-rejoin (car m) mod)
|
||||||
(list-ref m 2)
|
(list-ref m 2)
|
||||||
defn-phase
|
defn-phase
|
||||||
(list-ref m 1)
|
(list-ref m 1)
|
||||||
(list-ref m 3))
|
(list-ref m 3))
|
||||||
(list (module-path-index-rejoin m mod)
|
(list (module-path-index-rejoin m mod)
|
||||||
id
|
id
|
||||||
defn-phase
|
defn-phase
|
||||||
import-phase
|
import-phase
|
||||||
export-phase)))
|
export-phase)))
|
||||||
(reverse (cadr a)))
|
(reverse (cadr a)))
|
||||||
rqueue)
|
rqueue)
|
||||||
need-result?)
|
need-result?)
|
||||||
(begin
|
(begin
|
||||||
;; A dead end may not be our fault: the files could
|
;; A dead end may not be our fault: the files could
|
||||||
;; have changed in inconsistent ways. So just say #f
|
;; have changed in inconsistent ways. So just say #f
|
||||||
;; for now.
|
;; for now.
|
||||||
#;
|
#;
|
||||||
(error 'find-racket-tag
|
(error 'find-racket-tag
|
||||||
"dead end when looking for binding source: ~e"
|
"dead end when looking for binding source: ~e"
|
||||||
id)
|
id)
|
||||||
(loop queue rqueue need-result?)))))
|
(loop queue rqueue need-result?)))))
|
||||||
;; Can't get the module source, so continue with queue:
|
;; Can't get the module source, so continue with queue:
|
||||||
(loop queue rqueue need-result?)))])
|
(loop queue rqueue need-result?)))])
|
||||||
(or here-result
|
(or here-result
|
||||||
nest-result))))))])))))))
|
nest-result))))))]))))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user