137 lines
4.9 KiB
Racket
137 lines
4.9 KiB
Racket
#lang scheme/base
|
|
|
|
(require scribble/xref
|
|
scheme/fasl
|
|
scheme/path
|
|
racket/promise
|
|
setup/dirs
|
|
"getinfo.rkt"
|
|
"private/path-utils.rkt"
|
|
"doc-db.rkt")
|
|
|
|
(provide load-collections-xref
|
|
make-collections-xref)
|
|
|
|
(define cached-xref #f)
|
|
|
|
(define (get-dests no-user?)
|
|
(define main-dirs
|
|
(parameterize ([current-library-collection-paths
|
|
(let ([d (find-collects-dir)])
|
|
(if d (list d) null))])
|
|
(for/hash ([k (in-list (find-relevant-directories '(scribblings) 'no-planet))])
|
|
(values k #t))))
|
|
(apply
|
|
append
|
|
(for*/list ([dir (find-relevant-directories '(scribblings) 'all-available)]
|
|
[d (let ([info-proc (get-info/full dir)])
|
|
(if info-proc
|
|
(info-proc 'scribblings)
|
|
'()))])
|
|
(unless (and (list? d) (pair? d))
|
|
(error 'xref "bad scribblings entry: ~e" d))
|
|
(let* ([len (length d)]
|
|
[flags (if (len . >= . 2) (cadr d) '())]
|
|
[name (if (len . >= . 4)
|
|
(cadddr d)
|
|
(path->string
|
|
(path-replace-suffix (file-name-from-path (car d))
|
|
#"")))]
|
|
[out-count (if (len . >= . 5)
|
|
(list-ref d 4)
|
|
1)])
|
|
(if (not (and (len . >= . 3) (memq 'omit (caddr d))))
|
|
(let ([d (doc-path dir name flags (hash-ref main-dirs dir #f)
|
|
(if no-user? 'never 'false-if-missing))])
|
|
(if d
|
|
(for*/list ([i (in-range (add1 out-count))]
|
|
[p (in-value (build-path d (format "out~a.sxref" i)))]
|
|
#:when (file-exists? p))
|
|
p)
|
|
null))
|
|
null)))))
|
|
|
|
(define ((dest->source done-ht) dest)
|
|
(if (hash-ref done-ht dest #f)
|
|
(lambda () #f)
|
|
(lambda ()
|
|
(hash-set! done-ht dest #t)
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
(log-warning
|
|
"warning: ~a"
|
|
(if (exn? exn)
|
|
(exn-message exn)
|
|
(format "~e" exn)))
|
|
#f)])
|
|
(cadr (call-with-input-file* dest fasl->s-exp))))))
|
|
|
|
(define (make-key->source db-path no-user?)
|
|
(define main-db (cons (or db-path
|
|
(build-path (find-doc-dir) "docindex.sqlite"))
|
|
;; cache for a connection:
|
|
(box #f)))
|
|
(define user-db (and (not no-user?)
|
|
(cons (build-path (find-user-doc-dir) "docindex.sqlite")
|
|
;; cache for a connection:
|
|
(box #f))))
|
|
(define done-ht (make-hash)) ; tracks already-loaded documents
|
|
(define forced-all? #f)
|
|
(define (force-all)
|
|
;; force all documents
|
|
(define thunks (get-reader-thunks no-user? done-ht))
|
|
(set! forced-all? #t)
|
|
(lambda ()
|
|
;; return a procedure so we can produce a list of results:
|
|
(lambda ()
|
|
(for/list ([thunk (in-list thunks)])
|
|
(thunk)))))
|
|
(lambda (key)
|
|
(cond
|
|
[forced-all? #f]
|
|
[key
|
|
(define (try p)
|
|
(and p
|
|
(let* ([maybe-db (unbox (cdr p))]
|
|
[db
|
|
;; Use a cached connection, or...
|
|
(or (and (box-cas! (cdr p) maybe-db #f)
|
|
maybe-db)
|
|
;; ... create a new one
|
|
(and (file-exists? (car p))
|
|
(doc-db-file->connection (car p))))])
|
|
(and
|
|
db
|
|
(let ()
|
|
;; The db query:
|
|
(begin0
|
|
(doc-db-key->path db key)
|
|
;; cache the connection, if none is already cached:
|
|
(or (box-cas! (cdr p) #f db)
|
|
(doc-db-disconnect db))))))))
|
|
(define dest (or (try main-db) (try user-db)))
|
|
(and dest
|
|
(if (eq? dest #t)
|
|
(force-all)
|
|
((dest->source done-ht) dest)))]
|
|
[else
|
|
(unless forced-all?
|
|
(force-all))])))
|
|
|
|
(define (get-reader-thunks no-user? done-ht)
|
|
(map (dest->source done-ht)
|
|
(filter values (get-dests no-user?))))
|
|
|
|
(define (load-collections-xref [report-loading void])
|
|
(or cached-xref
|
|
(begin (report-loading)
|
|
(set! cached-xref
|
|
(make-collections-xref))
|
|
cached-xref)))
|
|
|
|
(define (make-collections-xref #:no-user? [no-user? #f]
|
|
#:doc-db [db-path #f])
|
|
(if (doc-db-available?)
|
|
(load-xref null
|
|
#:demand-source (make-key->source db-path no-user?))
|
|
(load-xref (get-reader-thunks no-user? (make-hash)))))
|