174 lines
7.5 KiB
Scheme
174 lines
7.5 KiB
Scheme
#reader scribble/reader
|
|
#lang scheme/base
|
|
|
|
(require scribble/decode
|
|
scribble/decode-struct
|
|
scribble/basic
|
|
scribble/struct
|
|
scribble/manual-struct
|
|
scheme/list
|
|
scheme/string
|
|
scheme/match
|
|
net/url
|
|
(only-in scheme/class send)
|
|
(only-in xml xexpr->string)
|
|
(only-in setup/dirs find-doc-dir)
|
|
"utils.ss"
|
|
scheme/runtime-path)
|
|
|
|
(provide make-search)
|
|
|
|
(define-runtime-path search-script "search.js")
|
|
|
|
(define (make-script user-dir? renderer sec ri)
|
|
(define dest-dir (send renderer get-dest-directory #t))
|
|
(define span-classes null)
|
|
;; To make the index smaller, html contents is represented as one of these:
|
|
;; - a string
|
|
;; - an array of contents to be concatenated
|
|
;; - a two-item array [idx, content], where idx is an index into the
|
|
;; span-classes table holding a class name.
|
|
;; In addition, a "file:/main-doc.../path..." url is saved as ">path..."
|
|
;; This function does the url compacting.
|
|
(define main-url ; (make sure that it teminates with a slash)
|
|
(if user-dir?
|
|
(regexp-replace #rx"/*$" (url->string (path->url (find-doc-dir))) "/")
|
|
"../"))
|
|
(define compact-url
|
|
(let ([rx (regexp (string-append "^" (regexp-quote main-url)))])
|
|
(lambda (url) (regexp-replace rx url ">"))))
|
|
;; This function does the html compacting.
|
|
(define (compact-body xexprs)
|
|
(define (compact xexprs)
|
|
(match xexprs
|
|
[`() xexprs]
|
|
[`("" . ,r) (compact r)]
|
|
[`(,(? string? s1) ,(? string? s2) . ,r)
|
|
(compact `(,(string-append s1 s2) . ,r))]
|
|
[`((span ([class ,c]) . ,b1) (span ([class ,c]) . ,b2) . ,r)
|
|
(compact `((span ([class ,c]) ,@b1 ,@b2) . ,r))]
|
|
[`((span ([class ,c]) . ,b) . ,r)
|
|
(let ([c (cond [(assoc c span-classes) => cdr]
|
|
[else (let ([n (length span-classes)])
|
|
(set! span-classes
|
|
(cons (cons c n) span-classes))
|
|
n)])])
|
|
(cons `(,c . ,(compact-body b)) (compact r)))]
|
|
[`(,x . ,r) (cons (xexpr->string x) (compact r))]))
|
|
;; generate javascript array code
|
|
(let loop ([body (compact xexprs)])
|
|
(if (andmap string? body)
|
|
(format "~s" (string-append* body))
|
|
(let ([body (map (lambda (x)
|
|
(if (string? x)
|
|
(format "~s" x)
|
|
(format "[~a,~a]" (car x) (cdr x))))
|
|
body)])
|
|
(if (= 1 (length body))
|
|
(car body)
|
|
(string-append* `("[" ,@(add-between body ",") "]")))))))
|
|
(define manual-refs (make-hash))
|
|
(define l
|
|
(for/list ([i (get-index-entries sec ri)] [idx (in-naturals)])
|
|
;; i is (list tag (text ...) (element ...) index-desc)
|
|
(define-values (tag texts elts desc) (apply values i))
|
|
(define text (string-downcase (string-join texts " ")))
|
|
(define-values (href html)
|
|
(let* ([e (add-between elts ", ")]
|
|
;; !!HACK!! The index entry for methods should have the extra
|
|
;; text in it (when it does, this should go away)
|
|
[e (if (method-index-desc? desc)
|
|
`(,@e ,(make-element "smaller"
|
|
`(" (method of "
|
|
,(make-element
|
|
"schemesymbol"
|
|
(list
|
|
(make-element
|
|
"schemevaluelink"
|
|
(list (symbol->string
|
|
(exported-index-desc-name desc))))))
|
|
")")))
|
|
e)]
|
|
[e (make-link-element "indexlink" e tag)]
|
|
[e (send renderer render-element e sec ri)])
|
|
(match e ; should always render to a single `a'
|
|
[`((a ([href ,href] [class "indexlink"]) . ,body))
|
|
(cond [(and (part-index-desc? desc)
|
|
(regexp-match #rx"(?:^|/)([^/]+)/index\\.html$" href))
|
|
=> (lambda (man) (hash-set! manual-refs (cadr man) idx))])
|
|
(let (;; throw away tooltips, we don't need them
|
|
[body (match body
|
|
[`((span ((title ,label)) . ,body))
|
|
(if (regexp-match? #rx"^Provided from: " label)
|
|
body
|
|
;; if this happens, this code should be updated
|
|
(error "internal error: unexpected tooltip"))]
|
|
[else body])])
|
|
(values (compact-url href) (compact-body body)))]
|
|
[else (error "something bad happened")])))
|
|
(define from-libs
|
|
(cond
|
|
[(exported-index-desc? desc)
|
|
(string-append*
|
|
`("["
|
|
,@(add-between
|
|
(map (lambda (x)
|
|
(format "~s"
|
|
(match x
|
|
[(? symbol?) (symbol->string x)]
|
|
[`',(? symbol? x)
|
|
(string-append "'" (symbol->string x))])))
|
|
(exported-index-desc-from-libs desc))
|
|
",")
|
|
"]"))]
|
|
[(module-path-index-desc? desc) "\"module\""]
|
|
[else "false"]))
|
|
;; Note: using ~s to have javascript-quoted strings
|
|
(format "[~s,~s,~a,~a]" text href html from-libs)))
|
|
|
|
(with-output-to-file (build-path dest-dir "plt-index.js") #:exists 'truncate
|
|
(lambda ()
|
|
(for-each
|
|
display
|
|
@`{// the url of the main doc tree, for compact url
|
|
// representation (see also the UncompactUrl function)
|
|
plt_main_url = @,(format "~s" main-url);@"\n"
|
|
// classes to be used for compact representation of html strings in
|
|
// plt_search_data below (see also the UncompactHtml function)
|
|
plt_span_classes = [
|
|
@,@(add-between (map (lambda (x) (format "~s" (car x)))
|
|
(reverse span-classes))
|
|
",\n ")];@"\n"
|
|
// this array has an entry of four items for each index link:
|
|
// - text is a string holding the indexed text
|
|
// - url holds the link (">" prefix means relative to plt_main_url)
|
|
// - html holds either a string, or [idx, html] where idx is an
|
|
// index into plt_span_classes (note: this is recursive)
|
|
// - from_lib is an array of module names for bound identifiers,
|
|
// or the string "module" for a module entry
|
|
plt_search_data = [
|
|
@,@(add-between l ",\n")];@"\n"
|
|
// array of pointers to the previous array, for items that are manuals
|
|
plt_manual_ptrs = {
|
|
@,@(let* ([ms (hash-map manual-refs cons)]
|
|
[ms (sort ms < #:key cdr)]
|
|
[ms (map (lambda (x) (format "~s: ~a" (car x) (cdr x)))
|
|
ms)])
|
|
(add-between ms ",\n "))};
|
|
})))
|
|
|
|
(let ([js (build-path dest-dir "search.js")])
|
|
(when (file-exists? js) (delete-file js))
|
|
(copy-file search-script js))
|
|
|
|
(list
|
|
(script-ref "plt-index.js"
|
|
#:noscript @list{Sorry, you must have JavaScript to use this page.})
|
|
(script-ref "search.js")
|
|
(make-element (make-with-attributes #f '((id . "plt_search_container")))
|
|
null)))
|
|
|
|
(define (make-search user-dir?)
|
|
(make-delayed-block (lambda (r s i)
|
|
(make-paragraph (make-script user-dir? r s i)))))
|