From e192679a2b7ea0fd205c358517e9b9ff41ae152b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 31 Jan 2008 00:06:54 +0000 Subject: [PATCH] small improvements to scribble data structures svn: r8481 original commit: 7e6ef8eeb5bbd071ac41675fdd23246b928eedac --- collects/scribble/base-render.ss | 23 ++++---- collects/scribble/basic.ss | 4 +- collects/scribble/html-render.ss | 61 ++++++++++++++-------- collects/scribble/manual.ss | 43 +++++++-------- collects/scribble/scheme.ss | 4 +- collects/scribble/search.ss | 32 +++++++++--- collects/scribble/struct.ss | 16 ++++-- collects/scribblings/scribble/struct.scrbl | 18 +++++-- 8 files changed, 128 insertions(+), 73 deletions(-) diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index 543dbaf5..b48c795d 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -70,7 +70,7 @@ (make-hash-table 'equal) (make-hash-table) (make-hash-table) - "" + null (make-hash-table) null)]) (start-collect ds fns ci) @@ -87,10 +87,9 @@ (collect-info-parts ci) (collect-info-tags ci) (if (part-tag-prefix d) - (string-append (collect-info-gen-prefix ci) - (part-tag-prefix d) - ":") - (collect-info-gen-prefix ci)) + (append (collect-info-gen-prefix ci) + (list (part-tag-prefix d))) + (collect-info-gen-prefix ci)) (collect-info-relatives ci) (cons d (collect-info-parents ci)))]) (when (part-title-content d) @@ -115,14 +114,20 @@ (let ([prefix (part-tag-prefix d)]) (for ([(k v) (collect-info-ht p-ci)]) (when (cadr k) - (collect-put! ci (if prefix (convert-key prefix k) k) v)))))) + (collect-put! ci (if prefix + (convert-key prefix k) + k) + v)))))) (define/private (convert-key prefix k) (case (car k) [(part tech) - (if (string? (cadr k)) - (list (car k) (string-append prefix ":" (cadr k))) - k)] + (let ([rhs (cadr k)]) + (if (or (string? rhs) (pair? rhs)) + (list (car k) (cons prefix (if (pair? rhs) + rhs + (list rhs)))) + k))] [(index-entry) (let ([v (convert-key prefix (cadr k))]) (if (eq? v (cadr k)) k (list 'index-entry v)))] diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index cae8025e..9408f0c0 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -180,7 +180,9 @@ (let ([key (make-generated-tag)] [content (decode-content s)]) (record-index (list (content->string content)) - (list (make-element #f content)) + (if (= 1 (length content)) + content + (list (make-element #f content))) key content))) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 68eefc47..3b7bc89b 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -179,7 +179,7 @@ (define/public (part-whole-page? p ri) (let ([dest (resolve-get p ri (car (part-tags p)))]) - (caddr dest))) + (dest-page? dest))) (define/public (current-part-whole-page? d) (eq? d (current-top-part))) @@ -189,21 +189,38 @@ (let ([key (generate-tag t ci)]) (collect-put! ci key - (list (path->relative (current-output-file)) - (or (part-title-content d) - '("???")) - (current-part-whole-page? d) - (format "~a" key))))) + (vector (path->relative (current-output-file)) + (or (part-title-content d) + '("???")) + (current-part-whole-page? d) + key)))) (part-tags d))) (define/override (collect-target-element i ci) (let ([key (generate-tag (target-element-tag i) ci)]) (collect-put! ci key - (list (path->relative (current-output-file)) - #f - (page-target-element? i) - (format "~a" key))))) + (vector (path->relative (current-output-file)) + #f + (page-target-element? i) + key)))) + + (define (dest-path dest) + (if (vector? dest) ; temporary + (vector-ref dest 0) + (list-ref dest 0))) + (define (dest-title dest) + (if (vector? dest) + (vector-ref dest 1) + (list-ref dest 1))) + (define (dest-page? dest) + (if (vector? dest) + (vector-ref dest 2) + (list-ref dest 2))) + (define (dest-anchor dest) + (if (vector? dest) + (vector-ref dest 3) + (list-ref dest 3))) ;; ---------------------------------------- @@ -211,10 +228,10 @@ (let ([dest (resolve-get #f ri tag)]) (if dest (values - (relative->path (car dest)) - (if (caddr dest) + (relative->path (dest-path dest)) + (if (dest-page? dest) #f - (anchor-name (cadddr dest)))) + (anchor-name (dest-anchor dest)))) (values #f #f)))) ;; ---------------------------------------- @@ -249,14 +266,14 @@ (td (a ((href ,(let ([dest (resolve-get p ri (car (part-tags p)))]) (format "~a~a~a" - (from-root (relative->path (car dest)) + (from-root (relative->path (dest-path dest)) (get-dest-directory)) - (if (caddr dest) + (if (dest-page? dest) "" "#") - (if (caddr dest) + (if (dest-page? dest) "" - (anchor-name (cadddr dest)))))) + (anchor-name (dest-anchor dest)))))) (class ,(if (eq? p mine) "tocviewselflink" "tocviewlink"))) @@ -629,19 +646,19 @@ (let ([dest (resolve-get part ri (link-element-tag e))]) (if dest `((a ((href ,(format "~a~a~a" - (from-root (relative->path (car dest)) + (from-root (relative->path (dest-path dest)) (get-dest-directory)) - (if (caddr dest) + (if (dest-page? dest) "" "#") - (if (caddr dest) + (if (dest-page? dest) "" - (anchor-name (cadddr dest))))) + (anchor-name (dest-anchor dest))))) ,@(if (string? (element-style e)) `((class ,(element-style e))) null)) ,@(if (null? (element-content e)) - (render-content (strip-aux (cadr dest)) part ri) + (render-content (strip-aux (dest-title dest)) part ri) (render-content (element-content e) part ri)))) (begin (when #f diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 712f1bef..77b6fbc9 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -338,15 +338,14 @@ (annote-exporting-library (to-element (make-just-context name stx-id)))))) - (define (libs->str libs) + (define (libs->taglet libs) (and (pair? libs) - (format "~a" - (let ([p (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join (car libs) #f)))]) - (if (path? p) - (path->main-collects-relative p) - p))))) + (let ([p (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join (car libs) #f)))]) + (if (path? p) + (intern-taglet (path->main-collects-relative p)) + p)))) (define (id-to-target-maker id dep?) (*id-to-target-maker 'def id dep?)) @@ -374,23 +373,22 @@ "no declared exporting libraries for definition" id))) (if e - (let* ([lib-str (libs->str (exporting-libraries-libs e))] + (let* ([lib-taglet (libs->taglet (exporting-libraries-libs e))] [tag (list (if sig (case sym [(def) 'sig-val] [(form) 'sig-def]) sym) - (format "~a::~a~a~a" - lib-str - (if sig (syntax-e (sig-id sig)) "") - (if sig "::" "") - (syntax-e id)))]) + (append + (list lib-taglet) + (if sig (list (syntax-e (sig-id sig))) null) + (list (syntax-e id))))]) (if (or sig (not dep?)) (list (mk tag)) (list (make-target-element #f (list (mk tag)) - `(dep ,(format "~a::~a" lib-str (syntax-e id))))))) + `(dep ,(list lib-taglet (syntax-e id))))))) content))) (lambda () (car content)) (lambda () (car content)))))) @@ -405,9 +403,9 @@ (make-delayed-element (lambda (renderer sec ri) (let* ([tag (find-scheme-tag sec ri sig 'for-label)] - [str (and tag (format "~a::~a" (cadr tag) elem))] - [vtag (and tag `(sig-val ,str))] - [stag (and tag `(sig-form ,str))] + [taglet (and tag (append (cadr tag) (list elem)))] + [vtag (and tag `(sig-val ,taglet))] + [stag (and tag `(sig-form ,taglet))] [sd (and stag (resolve-get/tentative sec ri stag))]) (list (make-element @@ -466,7 +464,7 @@ (define (method-tag vtag sym) (list 'meth - (format "~a::~a" (cadr vtag) sym))) + (list (cadr vtag) sym))) ;; ---------------------------------------- @@ -1767,9 +1765,8 @@ (define (doc-prefix doc s) (if doc - (format "~a:~a" - (module-path-prefix->string doc) - s) + (list (module-path-prefix->string doc) + s) s)) (define (secref s #:underline? [u? #t] #:doc [doc #f]) @@ -1956,7 +1953,7 @@ (let ([b (identifier-label-binding id)]) (list (let ([p (resolved-module-path-name (module-path-index-resolve (caddr b)))]) (if (path? p) - (path->main-collects-relative p) + (intern-taglet (path->main-collects-relative p)) p)) (cadddr b) (list-ref b 5)))) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 44a76ea3..16394d9a 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -182,9 +182,9 @@ (lambda (c) (make-element "highlighted" (list c))) values) - (if color? + (if (and color? cls) (make-element cls (list v)) - (make-element #f (list v)))) + v)) content)) (set! dest-col (+ dest-col len))]))])) (define advance diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss index bc2e5cfa..df69f147 100644 --- a/collects/scribble/search.ss +++ b/collects/scribble/search.ss @@ -4,7 +4,8 @@ setup/main-collects syntax/modcode) - (provide find-scheme-tag) + (provide find-scheme-tag + intern-taglet) (define module-info-cache (make-hash-table)) @@ -17,6 +18,24 @@ (module-path-index-join name (module-path-index-rejoin base rel-to))]))) + (define interned (make-hash-table 'equal 'weak)) + + (define (intern-taglet v) + (let ([v (if (list? v) + (map intern-taglet v) + v)]) + (if (or (string? v) + (bytes? v) + (list? v)) + (let ([b (hash-table-get interned v #f)]) + (if b + (weak-box-value b) + (begin + (hash-table-put! interned v (make-weak-box v)) + v))) + v))) + + ;; mode is #f, 'for-label, or 'for-run (define (find-scheme-tag part ri stx/binding mode) (let ([b (cond @@ -61,12 +80,11 @@ [queue (cdr queue)]) (let* ([rmp (module-path-index-resolve mod)] [eb (and here? - (format "~a::~a" - (let ([p (resolved-module-path-name rmp)]) - (if (path? p) - (path->main-collects-relative p) - p)) - id))]) + (list (let ([p (resolved-module-path-name rmp)]) + (if (path? p) + (intern-taglet (path->main-collects-relative p)) + p)) + id))]) (when (and eb (not search-key)) (set! search-key eb)) diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index c318db3a..7eabde40 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -124,7 +124,9 @@ (symbol? (car s)) (pair? (cdr s)) (or (string? (cadr s)) - (generated-tag? (cadr s))) + (generated-tag? (cadr s)) + (and (pair? (cadr s)) + (list? (cadr s)))) (null? (cddr s)))) (provide flow-element?) @@ -356,9 +358,9 @@ (list (car tg) (let ([tags (collect-info-tags ci)]) (or (hash-table-get tags t #f) - (let ([key (format "gentag:~a~a" - (collect-info-gen-prefix ci) - (hash-table-count tags))]) + (let ([key (list* 'gentag + (hash-table-count tags) + (collect-info-gen-prefix ci))]) (hash-table-put! tags t key) key))))) tg)) @@ -406,8 +408,12 @@ [(and (link-element? c) (null? (element-content c))) (let ([dest (resolve-get sec ri (link-element-tag c))]) + ;; FIXME: this is specific to renderer (if dest - (content->string (strip-aux (cadr dest)) renderer sec ri) + (content->string (strip-aux (if (pair? dest) + (cadr dest) + (vector-ref dest 1))) + renderer sec ri) "???"))] [(element? c) (content->string (element-content c) renderer sec ri)] [(delayed-element? c) diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index dae113de..d0b1f1a5 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -551,13 +551,23 @@ only during the @techlink{collect pass}. } -@defproc[(resolve-get [ri resolve-info?] [key any/c]) +@defproc[(resolve-get [p part?] [ri resolve-info?] [key any/c]) void?]{ Extract information during the @techlink{resolve pass} or -@techlink{render pass} from @scheme[ri], where the information was -previously registered during the @techlink{collect pass}. See also -@secref["passes"]. +@techlink{render pass} for @scheme[p] from @scheme[ri], where the +information was previously registered during the @techlink{collect +pass}. See also @secref["passes"]. + +} + +@defproc[(resolve-get-keys [p part?] [ri resolve-info?] + [pred (any/c . -> . any/c)]) + list?]{ + +Applies @scheme[pred] to each key mapped for @scheme[p] in +@scheme[ri], returning a list of all keys for which @scheme[pred] +returns a true value. }