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

add --redirect-main to scribble

Browse Source 
svn: r12230

original commit: 04369a39c7886125501cdb5e0ec79b91a2c33e78
This commit is contained in:
Matthew Flatt 2008-11-04 12:16:45 +00:00
parent 1e26551bb6
commit 53f9aad182
2 changed files with 35 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/scribble/html-render.ss
View File

@ -340,12 +340,16 @@
(define/public (set-external-tag-path p) (define/public (set-external-tag-path p)
(set! external-tag-path p)) (set! external-tag-path p))
(define external-root-url #f)
(define/public (set-external-root-url p)
(set! external-root-url p))
(define/public (tag->path+anchor ri tag) (define/public (tag->path+anchor ri tag)
;; Called externally; not used internally ;; Called externally; not used internally
(let-values ([(dest ext?) (resolve-get/ext? #f ri tag)]) (let-values ([(dest ext?) (resolve-get/ext? #f ri tag)])
(cond [(not dest) (values #f #f)] (cond [(not dest) (values #f #f)]
[(and ext? external-tag-path) [(and ext? external-tag-path)
(values external-tag-path (format "~a" (serialize tag)))] (values (string->url external-tag-path) (format "~a" (serialize tag)))]
[else (values (relative->path (dest-path dest)) [else (values (relative->path (dest-path dest))
(and (not (dest-page? dest)) (and (not (dest-page? dest))
(anchor-name (dest-anchor dest))))]))) (anchor-name (dest-anchor dest))))])))
@ -845,7 +849,26 @@
(resolve-get/ext? part ri (link-element-tag e))]) (resolve-get/ext? part ri (link-element-tag e))])
(if dest (if dest
`((a [(href `((a [(href
,(if (and ext? external-tag-path) ,(cond
[(and ext? external-root-url
(let ([rel (find-relative-path
(find-doc-dir)
(relative->path (dest-path dest)))])
(and (relative-path? rel)
rel)))
=> (lambda (rel)
(url->string
(struct-copy
url
(combine-url/relative
(string->url external-root-url)
(string-join (map path-element->string
(explode-path rel))
"/"))
[fragment
(and (not (dest-page? dest))
(anchor-name (dest-anchor dest)))])))]
[(and ext? external-tag-path)
;; Redirected to search: ;; Redirected to search:
(url->string (url->string
(let ([u (string->url external-tag-path)]) (let ([u (string->url external-tag-path)])
@ -859,7 +882,8 @@
(string->bytes/utf-8 (string->bytes/utf-8
(format "~a" (serialize (format "~a" (serialize
(link-element-tag e))))))) (link-element-tag e)))))))
(url-query u))]))) (url-query u))])))]
[else
;; Normal link: ;; Normal link:
(format "~a~a~a" (format "~a~a~a"
(from-root (relative->path (dest-path dest)) (from-root (relative->path (dest-path dest))
@ -867,7 +891,7 @@
(if (dest-page? dest) "" "#") (if (dest-page? dest) "" "#")
(if (dest-page? dest) (if (dest-page? dest)
"" ""
(anchor-name (dest-anchor dest)))))) (anchor-name (dest-anchor dest))))]))
,@(if (string? (element-style e)) ,@(if (string? (element-style e))
`([class ,(element-style e)]) `([class ,(element-style e)])
null)] null)]

8
collects/scribble/run.ss
View File

@ -38,6 +38,8 @@
(make-parameter null)) (make-parameter null))
(define current-redirect (define current-redirect
(make-parameter #f)) (make-parameter #f))
(define current-redirect-main
(make-parameter #f))
(define (read-one str) (define (read-one str)
(let ([i (open-input-string str)]) (let ([i (open-input-string str)])
@ -67,8 +69,10 @@
(current-dest-name name)] (current-dest-name name)]
[("--style") file "use given base .css/.tex file" [("--style") file "use given base .css/.tex file"
(current-style-file file)] (current-style-file file)]
[("--redirect") url "redirect external tag links to <url>" [("--redirect") url "redirect external links to tag search via <url>"
(current-redirect url)] (current-redirect url)]
[("--redirect-main") url "redirect main doc links to <url>"
(current-redirect-main url)]
[("--info-out") file "write format-specific link information to <file>" [("--info-out") file "write format-specific link information to <file>"
(current-info-output-file file)]] (current-info-output-file file)]]
[multi [multi
@ -110,6 +114,8 @@
[style-extra-files (reverse (current-style-extra-files))])]) [style-extra-files (reverse (current-style-extra-files))])])
(when (current-redirect) (when (current-redirect)
(send renderer set-external-tag-path (current-redirect))) (send renderer set-external-tag-path (current-redirect)))
(when (current-redirect-main)
(send renderer set-external-root-url (current-redirect-main)))
(send renderer report-output!) (send renderer report-output!)
(let* ([fns (map (lambda (fn) (let* ([fns (map (lambda (fn)
(let-values ([(base name dir?) (split-path fn)]) (let-values ([(base name dir?) (split-path fn)])