Skip to content
Closed
31 changes: 12 additions & 19 deletions scribble-lib/scribble/private/doc-begin.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -66,22 +66,15 @@
#'(check-pre-part s (quote-syntax loc))))]))

(define (check-pre-part v loc-stx)
(if (pre-part? v)
v
(error
(format
"~a: not valid in document body (need a pre-part for decode) in: ~e"
(cond
[(and (syntax-source loc-stx)
(syntax-line loc-stx))
(format "~a:~a:~a"
(syntax-source loc-stx)
(syntax-line loc-stx)
(syntax-column loc-stx))]
[(and (syntax-source loc-stx)
(syntax-position loc-stx))
(format "~a:::~a"
(syntax-source loc-stx)
(syntax-position loc-stx))]
[else 'document])
v))))
(unless (pre-part? v)
(error
(format
"~a: not valid in document body (need a pre-part for decode) in: ~e"
(cond
[(and (syntax-source loc-stx) (syntax-line loc-stx))
(format "~a:~a:~a" (syntax-source loc-stx) (syntax-line loc-stx) (syntax-column loc-stx))]
[(and (syntax-source loc-stx) (syntax-position loc-stx))
(format "~a:::~a" (syntax-source loc-stx) (syntax-position loc-stx))]
[else 'document])
v)))
v)
189 changes: 85 additions & 104 deletions scribble-lib/scribble/private/manual-bind.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -59,10 +59,7 @@
(define hovers (make-weak-hasheq))
(define (intern-hover-style text)
(let ([text (datum-intern-literal text)])
(or (hash-ref hovers text #f)
(let ([s (make-style #f (list (make-hover-property text)))])
(hash-set! hovers text s)
s))))
(hash-ref! hovers text (λ () (make-style #f (list (make-hover-property text)))))))

(define (annote-exporting-library e)
(make-delayed-element
Expand All @@ -71,15 +68,14 @@
(if (and from (pair? from))
(make-element
(intern-hover-style
(string-append
"Provided from: "
(string-join (map ~s from) ", ")
(let ([from-pkgs (resolve-get/tentative p ri '(exporting-packages #f))])
(if (and from-pkgs (pair? from-pkgs))
(string-append
" | Package: "
(string-join (map ~a from-pkgs) ", "))
""))))
(string-join (map ~s from)
", "
#:before-first "Provided from: "
#:after-last
(let ([from-pkgs (resolve-get/tentative p ri '(exporting-packages #f))])
(if (and from-pkgs (pair? from-pkgs))
(string-append " | Package: " (string-join (map ~a from-pkgs) ", "))
""))))
e)
e))
(lambda () e)
Expand Down Expand Up @@ -114,30 +110,30 @@
(lambda (x add) x)))
(let ([lib
(or (for/or ([lib (in-list (or source-libs null))])
(let ([checker
(hash-ref
checkers lib
(lambda ()
(define ns-id
(let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns])
;; A `(namespace-require `(for-label ,lib))` can
;; fail if `lib` provides different bindings of the
;; same name at different phases. We can require phases
;; 1 and 0 separately, in which case the phase-0
;; binding shadows the phase-1 one in that case.
;; This strategy only works for documenting bindings
;; at phases 0 and 1, though.
(namespace-require `(just-meta 1 (for-label ,lib)))
(namespace-require `(just-meta 0 (for-label ,lib)))
(namespace-syntax-introduce (datum->syntax #f 'x)))))
(define (checker id intro)
(free-label-identifier=?
(intro (datum->syntax ns-id (syntax-e id)) 'add)
(intro id 'add)))
(hash-set! checkers lib checker)
checker))])
(and (checker id intro) lib)))
(define checker
(hash-ref checkers
lib
(lambda ()
(define ns-id
(let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns])
;; A `(namespace-require `(for-label ,lib))` can
;; fail if `lib` provides different bindings of the
;; same name at different phases. We can require phases
;; 1 and 0 separately, in which case the phase-0
;; binding shadows the phase-1 one in that case.
;; This strategy only works for documenting bindings
;; at phases 0 and 1, though.
(namespace-require `(just-meta 1 (for-label ,lib)))
(namespace-require `(just-meta 0 (for-label ,lib)))
(namespace-syntax-introduce (datum->syntax #f 'x)))))
(define (checker id intro)
(free-label-identifier=? (intro (datum->syntax ns-id (syntax-e id))
'add)
(intro id 'add)))
(hash-set! checkers lib checker)
checker)))
(and (checker id intro) lib))
(and (pair? libs) (car libs)))])
(and lib (module-path-index->taglet
(module-path-index-join lib #f)))))
Expand Down Expand Up @@ -198,79 +194,64 @@
#:show-libs? [show-libs? #t])
;; This function could have more optional argument to select
;; whether to index the id, include a toc link, etc.
(let ([dep? #t])
(define maker
(if form?
(id-to-form-target-maker id dep?)
(id-to-target-maker id dep?)))
(define-values (elem elem-ref)
(if show-libs?
(definition-site (syntax-e id) id form?)
(values (to-element id #:defn? #t)
(to-element id))))
(if maker
(maker elem
(lambda (tag)
(let ([elem
(if index?
(make-index-element
#f (list elem) tag
(list (datum-intern-literal (symbol->string (syntax-e id))))
(list elem)
(and show-libs?
(with-exporting-libraries
(lambda (libs)
(make-exported-index-desc (syntax-e id)
libs)))))
elem)])
(make-target-element #f (list elem) tag))))
elem)))
(define dep? #t)
(define maker
(if form?
(id-to-form-target-maker id dep?)
(id-to-target-maker id dep?)))
(define-values (elem elem-ref)
(if show-libs?
(definition-site (syntax-e id) id form?)
(values (to-element id #:defn? #t) (to-element id))))
(if maker
(maker elem
(lambda (tag)
(let ([elem (if index?
(make-index-element
#f
(list elem)
tag
(list (datum-intern-literal (symbol->string (syntax-e id))))
(list elem)
(and show-libs?
(with-exporting-libraries
(lambda (libs) (make-exported-index-desc (syntax-e id) libs)))))
elem)])
(make-target-element #f (list elem) tag))))
elem))

(define (make-binding-redirect-elements mod-path redirects)
(define taglet (module-path-index->taglet
(module-path-index-join mod-path #f)))
(make-element
#f
(map
(lambda (redirect)
(define id (car redirect))
(define form? (cadr redirect))
(define path (caddr redirect))
(define anchor (cadddr redirect))
(define (make-one kind)
(make-redirect-target-element
#f
null
(intern-taglet (list kind (list taglet id)))
path
anchor))
(make-element
#f
(list (make-one (if form? 'form 'def))
(make-dep (list taglet id) null)
(let ([str (datum-intern-literal (symbol->string id))])
(make-index-element #f
null
(intern-taglet
(list (if form? 'form 'def)
(list taglet id)))
(list str)
(list
(make-element
symbol-color
(list
(make-element
(if form?
syntax-link-color
value-link-color)
(list str)))))
(make-exported-index-desc*
id
(list mod-path)
(hash 'kind (if form?
"syntax"
"procedure"))))))))
redirects)))
(for/list ([redirect (in-list redirects)])
(define id (car redirect))
(define form? (cadr redirect))
(define path (caddr redirect))
(define anchor (cadddr redirect))
(define (make-one kind)
(make-redirect-target-element #f
null
(intern-taglet (list kind (list taglet id)))
path
anchor))
(make-element
#f
(list (make-one (if form? 'form 'def))
(make-dep (list taglet id) null)
(let ([str (datum-intern-literal (symbol->string id))])
(make-index-element
#f
null
(intern-taglet (list (if form? 'form 'def) (list taglet id)))
(list str)
(list (make-element symbol-color
(list (make-element (if form? syntax-link-color value-link-color)
(list str)))))
(make-exported-index-desc* id
(list mod-path)
(hash 'kind (if form? "syntax" "procedure"))))))))))


(define (make-dep t content)
Expand Down
39 changes: 15 additions & 24 deletions scribble-lib/scribble/private/manual-class.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -48,14 +48,9 @@

(define (id-info id)
(define b (identifier-label-binding id))
(if b
(list (caddr b)
(list-ref b 3)
(list-ref b 4)
(list-ref b 5)
(list-ref b 6))
(error 'scribble "no class/interface/mixin information for identifier: ~e"
id)))
(unless b
(error 'scribble "no class/interface/mixin information for identifier: ~e" id))
(list (caddr b) (list-ref b 3) (list-ref b 4) (list-ref b 5) (list-ref b 6)))
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

A combination of take and drop would be better IMO

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Excellent idea. Added in jackfirth/resyntax#444.


(define (make-inherited-table r d ri decl)
(define start
Expand Down Expand Up @@ -155,11 +150,11 @@
null))

(define (build-body decl body)
`(,@(map (lambda (i)
(cond [(constructor? i) ((constructor-def i))]
[(meth? i) ((meth-def i))]
[else i]))
body)
`(,@(for/list ([i (in-list body)])
(cond
[(constructor? i) ((constructor-def i))]
[(meth? i) ((meth-def i))]
[else i]))
,(make-delayed-block (lambda (r d ri) (make-inherited-table r d ri decl)))))

(define (*include-class/title decl link?)
Expand Down Expand Up @@ -408,17 +403,13 @@
(datum->syntax n (syntax-e n) (list 'src 1 3 4 1)))
(list 'src 1 0 1 5))]
[(((kw ...) ...) ...)
(map (lambda (ids)
(map (lambda (arg)
(if (and (pair? (syntax-e arg))
(eq? (syntax-e #'mode) 'new))
(list (string->keyword
(symbol->string
(syntax-e
(car (syntax-e arg))))))
null))
(syntax->list ids)))
(syntax->list #'((arg ...) ...)))])
(for/list ([ids (in-list (syntax->list #'((arg ...) ...)))])
(map (lambda (arg)
(if (and (pair? (syntax-e arg)) (eq? (syntax-e #'mode) 'new))
(list (string->keyword
(symbol->string (syntax-e (car (syntax-e arg))))))
null))
(syntax->list ids)))])
#'(make-constructor (lambda ()
(defproc* #:mode mode #:within name
[[(make [kw ... . arg] ...) result] ...]
Expand Down
17 changes: 10 additions & 7 deletions scribble-lib/scribble/private/manual-code.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -340,16 +340,19 @@
(list 'function start end 1)] ; this looses information
[_ tok])))

(define (make-test-result lst)
(define-values (res _)
(for/fold ([result null] [count 12])
(define (make-test-result lst)
(define res
(for/fold ([result null]
[count 12]
#:result result)
([p lst])
(define next (+ count (second p)))
(define r (if (eq? (first p) 'function) 1 0))
(values
(cons (list (first p) count next r) result)
next)))
(list* `(function 0 5 1) `(white-space 5 6 0) `(function 6 12 1) `(function 6 12 1)
(values (cons (list (first p) count next r) result) next)))
(list* `(function 0 5 1)
`(white-space 5 6 0)
`(function 6 12 1)
`(function 6 12 1)
(reverse res)))

(check-equal?
Expand Down
21 changes: 9 additions & 12 deletions scribble-lib/scribble/private/manual-mod.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -299,12 +299,9 @@
pkg-spec))))
libs-specs))
(append (if link-target?
(map (lambda (modpath)
(make-part-tag-decl
(intern-taglet
`(mod-path ,(datum-intern-literal
(element->string modpath))))))
modpaths)
(for/list ([modpath (in-list modpaths)])
(make-part-tag-decl (intern-taglet `(mod-path ,(datum-intern-literal
(element->string modpath))))))
null)
(flow-paragraphs (decode-flow content)))))))

Expand Down Expand Up @@ -334,12 +331,12 @@
#'(list pkg ...)
#'#f)])
(let ([libs (syntax->list #'(lib ... plib ...))])
(for ([l libs])
(unless (or (syntax-case l (unquote)
[(unquote _) #t]
[_ #f])
(module-path? (syntax->datum l)))
(raise-syntax-error #f "not a module path" stx l)))
(for ([l libs]
#:unless (or (syntax-case l (unquote)
[(unquote _) #t]
[_ #f])
(module-path? (syntax->datum l))))
(raise-syntax-error #f "not a module path" stx l))
(when (null? libs)
(raise-syntax-error #f "need at least one module path" stx))
#'(*declare-exporting `(lib ...) `(plib ...) packages)))]))
Expand Down
Loading