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