suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco setup: fix problem with doc index database

Browse Source 
When a tag is serializable but not `write'--`read' invariant,
then it needs to be serialized and deserialized.

Also, clarify and check in `tag?' that a tag should be
serializable.
This commit is contained in:
Matthew Flatt 2012-12-13 15:32:17 -07:00
parent f374cb184d
commit 6eef00a312
4 changed files with 56 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/scribble/core.rkt
View File

@ -93,7 +93,8 @@
(or (string? (cadr s))
(generated-tag? (cadr s))
(and (pair? (cadr s))
(list? (cadr s))))
(list? (cadr s))
(serializable? (cadr s))))
(null? (cddr s))))
(provide block?)

5
collects/scribblings/scribble/core.scrbl
View File

@ -3,6 +3,7 @@
(except-in "utils.rkt" url)
"struct-hierarchy.rkt"
(for-label scribble/manual-struct
racket/serialize
file/convertible
setup/main-collects
scriblib/render-cond
@ -1157,8 +1158,8 @@ or @racket[style] structure.}
Returns @racket[#t] if @racket[v] is acceptable as a link
@techlink{tag}, which is a list containing a symbol and either a
string, a @racket[generated-tag] instance, or a list (of arbitrary
values).}
string, a @racket[generated-tag] instance, or a non-empty list
of @racket[serializable?] values.}
@defstruct[generated-tag ()]{

54
collects/setup/doc-db.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require db
racket/format
racket/serialize
"main-doc.rkt")
(provide doc-db-available?
@ -89,10 +90,10 @@
'doc-db-key->path
db-file
(lambda (db)
(define row (query-maybe-row db select-pathid-vq
(~s key)))
(define pathid (and row
(vector-ref row 0)))
(define rows (query-rows db select-pathid-vq
(->string key)))
(define pathid (and (pair? rows)
(vector-ref (car rows) 0)))
(and pathid
(pathid->filename db pathid #f main-doc-relative-ok?)))))
@ -106,7 +107,7 @@
(prepare-tables db)
(define pathid (filename->pathid db filename))
(for ([p (in-list elems)])
(define stag (~s p))
(define stag (->string p))
(callback db stag pathid)))))
(define (clear who db-file filename statement)
@ -161,9 +162,9 @@
(query-exec db "INSERT INTO searchSets VALUES ($1, $2, $3)"
pathid
setid
(~s sk))
(->string sk))
(for ([k (in-hash-keys s)])
(define stag (~s k))
(define stag (->string k))
(query-exec db "INSERT INTO searches VALUES ($1, $2, $3)"
pathid
setid
@ -226,7 +227,7 @@
" WHERE stag=$1")
stag)
null))
(cons (read (if (bytes? stag)
(cons (<-string (if (bytes? stag)
(open-input-bytes stag)
(open-input-string stag)))
(append
@ -284,7 +285,7 @@
" GROUP BY SS.stag")
pathid))
(map (lambda (s)
(read (open-input-string (vector-ref s 0))))
(<-string (open-input-string (vector-ref s 0))))
(append
rows
more-rows)))))
@ -342,7 +343,7 @@
[(equal? "y" (vector-ref row 0))
(main-doc-relative->path
(cons 'doc (or (hash-ref reader-cache bstr #f)
(let ([v (read (open-input-bytes bstr))])
(let ([v (<-string (open-input-bytes bstr))])
(hash-set! reader-cache bstr v)
v))))]
[(bytes? bstr)
@ -370,7 +371,7 @@
(define filename* (path->main-doc-relative filename))
(define filename-bytes (cond
[(pair? filename*)
(string->bytes/utf-8 (~s (cdr filename*)))]
(string->bytes/utf-8 (->string (cdr filename*)))]
[(path? filename*)
(path->bytes filename*)]
[else (path->bytes (string->path filename*))]))
@ -401,7 +402,7 @@
(if (equal? "y" (vector-ref row 0))
((if main-doc-relative-ok? values main-doc-relative->path)
(cons 'doc (or (hash-ref reader-cache path #f)
(let ([v (read (open-input-bytes path))])
(let ([v (<-string (open-input-bytes path))])
(hash-set! reader-cache path v)
v))))
(bytes->path path)))))
@ -494,3 +495,32 @@
(call-with-lock-handler
(lambda () (loop (doc-db-pause `(query ,who) pause)))
thunk)))
(define (readable? s)
(or (string? s)
(bytes? s)
(symbol? s)
(number? s)
(boolean? s)
(and (list? s) (andmap readable? s))
(and (vector? s) (for/and ([v (in-vector s)]) (readable? s)))))
(define (->string v)
(if (and (not (box? v))
(readable? v))
(~s v)
(~s (box (serialize v)))))
(define (<-string p)
(with-handlers ([exn:fail:read?
(lambda (exn)
(error 'read
(~a "error unmarshaling from database\n"
" original error: ~e")
(exn-message exn)))])
(define v (read p))
(if (box? v)
;; A box indicates serialization:
(deserialize (unbox v))
;; Normal value:
v)))

8
collects/setup/setup-unit.rkt
View File

@ -649,7 +649,13 @@
(define fn (build-path p "info-domain" "compiled" "cache.rktd"))
(when (file-exists? fn)
(with-handlers ([exn:fail:filesystem? (warning-handler (void))])
(with-output-to-file fn void #:exists 'truncate/replace))))))
(with-output-to-file fn void #:exists 'truncate/replace))))
(setup-printf #f "deleting documentation databases")
(for ([d (in-list (list (find-doc-dir) (find-user-doc-dir)))])
(when d
(define f (build-path d "docindex.sqlite"))
(when (file-exists? f)
(delete-file f))))))
(define (do-install-part part)
(when (if (eq? part 'post) (call-post-install) (call-install))