suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

scribble: render `pict' content directly

Browse Source 
--- actually, any value that is convertible to PNG/PDF

original commit: 0f86dc15afe6d0bf48a77f8aec7d66fda356082b
This commit is contained in:
Matthew Flatt 2010-11-26 17:49:46 -07:00
parent e30aedf47f
commit 6fb5dc58de
5 changed files with 67 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/scribble/base-render.rkt
View File

@ -8,6 +8,7 @@
scheme/path scheme/path
setup/main-collects setup/main-collects
setup/path-relativize setup/path-relativize
file/convertible
"render-struct.ss") "render-struct.ss")
(provide render%) (provide render%)
@ -677,6 +678,7 @@
(render-content (traverse-element-content i ri) part ri)] (render-content (traverse-element-content i ri) part ri)]
[(part-relative-element? i) [(part-relative-element? i)
(render-content (part-relative-element-content i ri) part ri)] (render-content (part-relative-element-content i ri) part ri)]
[(convertible? i) (list "???")]
[else (render-other i part ri)])) [else (render-other i part ri)]))
(define/public (render-other i part ri) (define/public (render-other i part ri)
@ -687,13 +689,15 @@
(define copied-srcs (make-hash)) (define copied-srcs (make-hash))
(define copied-dests (make-hash)) (define copied-dests (make-hash))
(define/public (install-file fn) (define/public (install-file fn [content #f])
(if refer-to-existing-files (if (and refer-to-existing-files
(not content))
(if (string? fn) (if (string? fn)
(string->path fn) (string->path fn)
fn) fn)
(let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))]) (let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))])
(or (hash-ref copied-srcs normalized #f) (or (and (not content)
(hash-ref copied-srcs normalized #f))
(let ([src-dir (path-only fn)] (let ([src-dir (path-only fn)]
[dest-dir (get-dest-directory #t)] [dest-dir (get-dest-directory #t)]
[fn (file-name-from-path fn)]) [fn (file-name-from-path fn)])
@ -715,22 +719,26 @@
(let-values ([(dest-file normalized-dest-file) (let-values ([(dest-file normalized-dest-file)
(let loop ([dest-file dest-file]) (let loop ([dest-file dest-file])
(let ([normalized-dest-file (let ([normalized-dest-file
(normal-case-path (simplify-path (path->complete-path dest-file)))]) (normal-case-path (simplify-path (path->complete-path dest-file)))]
(if (file-exists? dest-file) [check-same
(cond
[(call-with-input-file*
src-file
(lambda (src) (lambda (src)
(call-with-input-file* (call-with-input-file*
dest-file dest-file
(lambda (dest) (lambda (dest)
(or (equal? (port-file-identity src) (or (and (not content)
(port-file-identity dest)) (equal? (port-file-identity src)
(port-file-identity dest)))
(let loop () (let loop ()
(let ([s (read-bytes 4096 src)] (let ([s (read-bytes 4096 src)]
[d (read-bytes 4096 dest)]) [d (read-bytes 4096 dest)])
(and (equal? s d) (and (equal? s d)
(or (eof-object? s) (loop)))))))))) (or (eof-object? s) (loop)))))))))])
(if (file-exists? dest-file)
(cond
[(or (and content
(check-same (open-input-bytes content)))
(and (not content)
(call-with-input-file* src-file check-same)))
;; same content at that destination ;; same content at that destination
(values dest-file normalized-dest-file)] (values dest-file normalized-dest-file)]
[(hash-ref copied-dests normalized-dest-file #f) [(hash-ref copied-dests normalized-dest-file #f)
@ -743,10 +751,15 @@
;; new file ;; new file
(values dest-file normalized-dest-file))))]) (values dest-file normalized-dest-file))))])
(unless (file-exists? dest-file) (unless (file-exists? dest-file)
(copy-file src-file dest-file)) (if content
(call-with-output-file*
dest-file
(lambda (dest) (write-bytes content dest)))
(copy-file src-file dest-file)))
(hash-set! copied-dests normalized-dest-file #t) (hash-set! copied-dests normalized-dest-file #t)
(let ([result (path->string (file-name-from-path dest-file))]) (let ([result (path->string (file-name-from-path dest-file))])
(hash-set! copied-srcs normalized result) (unless content
(hash-set! copied-srcs normalized result))
result)))))))) result))))))))
;; ---------------------------------------- ;; ----------------------------------------

6
collects/scribble/core.rkt
View File

@ -1,7 +1,8 @@
#lang scheme/base #lang scheme/base
(require "private/provide-structs.ss" (require "private/provide-structs.ss"
scheme/serialize scheme/serialize
scheme/contract) scheme/contract
file/convertible)
;; ---------------------------------------- ;; ----------------------------------------
@ -119,7 +120,8 @@
(traverse-element? v) (traverse-element? v)
(part-relative-element? v) (part-relative-element? v)
(multiarg-element? v) (multiarg-element? v)
(hash-ref content-symbols v #f))) (hash-ref content-symbols v #f)
(convertible? v)))
(provide element-style?) (provide element-style?)
(define (element-style? s) (define (element-style? s)

10
collects/scribble/html-render.rkt
View File

@ -9,6 +9,7 @@
scheme/port scheme/port
scheme/list scheme/list
scheme/string scheme/string
file/convertible
mzlib/runtime-path mzlib/runtime-path
setup/main-doc setup/main-doc
setup/main-collects setup/main-collects
@ -947,6 +948,15 @@
(cond (cond
[(string? e) (super render-content e part ri)] ; short-cut for common case [(string? e) (super render-content e part ri)] ; short-cut for common case
[(list? e) (super render-content e part ri)] ; also a short-cut [(list? e) (super render-content e part ri)] ; also a short-cut
[(and (convertible? e)
(convert e 'png-bytes))
=> (lambda (bstr)
(let ([w (integer-bytes->integer (subbytes bstr 16 20) #f #t)]
[h (integer-bytes->integer (subbytes bstr 20 24) #f #t)])
`((img ([src ,(install-file "pict.png" bstr)]
[alt "image"]
[width ,(number->string w)]
[height ,(number->string h)])))))]
[(image-element? e) [(image-element? e)
(let* ([src (main-collects-relative->path (image-element-path e))] (let* ([src (main-collects-relative->path (image-element-path e))]
[suffixes (image-element-suffixes e)] [suffixes (image-element-suffixes e)]

17
collects/scribble/latex-render.rkt
View File

@ -9,7 +9,8 @@
scheme/path scheme/path
scheme/string scheme/string
scheme/list scheme/list
setup/main-collects) setup/main-collects
file/convertible)
(provide render-mixin) (provide render-mixin)
(define current-table-mode (make-parameter #f)) (define current-table-mode (make-parameter #f))
@ -235,7 +236,8 @@
es)] es)]
[style (and (style? es) es)] [style (and (style? es) es)]
[core-render (lambda (e tt?) [core-render (lambda (e tt?)
(if (and (image-element? e) (cond
[(and (image-element? e)
(not (disable-images))) (not (disable-images)))
(let ([fn (install-file (let ([fn (install-file
(select-suffix (select-suffix
@ -244,9 +246,16 @@
(image-element-suffixes e) (image-element-suffixes e)
'(".pdf" ".ps" ".png")))]) '(".pdf" ".ps" ".png")))])
(printf "\\includegraphics[scale=~a]{~a}" (printf "\\includegraphics[scale=~a]{~a}"
(image-element-scale e) fn)) (image-element-scale e) fn))]
[(and (convertible? e)
(not (disable-images))
(convert e 'pdf-bytes))
=> (lambda (bstr)
(let ([fn (install-file "pict.pdf" bstr)])
(printf "\\includegraphics{~a}" fn)))]
[else
(parameterize ([rendering-tt (or tt? (rendering-tt))]) (parameterize ([rendering-tt (or tt? (rendering-tt))])
(super render-content e part ri))))] (super render-content e part ri))]))]
[wrap (lambda (e s tt?) [wrap (lambda (e s tt?)
(printf "\\~a{" s) (printf "\\~a{" s)
(core-render e tt?) (core-render e tt?)

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

@ -943,8 +943,9 @@ otherwise.}
Returns @racket[#t] if @racket[v] is a string, symbol, Returns @racket[#t] if @racket[v] is a string, symbol,
@racket[element], @racket[multiarg-element], @racket[element], @racket[multiarg-element],
@racket[traverse-element], @racket[delayed-element], @racket[traverse-element], @racket[delayed-element],
@racket[part-relative-element], or list of @tech{content}, @racket[#f] @racket[part-relative-element], a convertible value in
otherwise.} the sense of @racket[convertible?], or list of @tech{content}.
Otherwise, it returns @racket[#f].}
@defstruct[style ([name (or/c string? symbol? #f)] @defstruct[style ([name (or/c string? symbol? #f)]