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

checkpoint GUI manual work

Browse Source 
svn: r7117

original commit: c9f1aec9eb0491a6e80f5454815361a79c92618a
This commit is contained in:
Matthew Flatt 2007-08-18 12:22:05 +00:00
parent 6d55647707
commit f45096ef94
3 changed files with 101 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -68,16 +68,27 @@
(define/override (collect-target-element i ht) (define/override (collect-target-element i ht)
(hash-table-put! ht (hash-table-put! ht
(target-element-tag i) (target-element-tag i)
(list (current-output-file) #f #f))) (list (current-output-file)
#f
(page-target-element? i))))
;; ---------------------------------------- ;; ----------------------------------------
(define/private (reveal-subparts? p)
(and (styled-part? p)
(let ([s (styled-part-style p)])
(or (eq? s 'reveal)
(and (list? s)
(memq 'reveal s))))))
(define/public (render-toc-view d ht) (define/public (render-toc-view d ht)
(let-values ([(top mine) (let-values ([(top mine)
(let loop ([d d][mine d]) (let loop ([d d][mine d])
(let ([p (collected-info-parent (part-collected-info d))]) (let ([p (collected-info-parent (part-collected-info d))])
(if p (if p
(loop p d) (loop p (if (reveal-subparts? d)
mine
d))
(values d mine))))]) (values d mine))))])
`((div ((class "tocset")) `((div ((class "tocset"))
(div ((class "tocview")) (div ((class "tocview"))
@ -89,28 +100,39 @@
(table (table
((class "tocviewlist") ((class "tocviewlist")
(cellspacing "0")) (cellspacing "0"))
,@(map (lambda (p) ,@(map (lambda (pp)
`(tr (let ([p (car pp)]
(td [show-number? (cdr pp)])
((align "right")) `(tr
,@(format-number (collected-info-number (part-collected-info p)) (td
'((tt nbsp)))) ((align "right"))
(td ,@(if show-number?
(a ((href ,(let ([dest (lookup p ht `(part ,(car (part-tags p))))]) (format-number (collected-info-number (part-collected-info p))
(format "~a~a~a" '((tt nbsp)))
(from-root (car dest) '("-" nbsp)))
(get-dest-directory)) (td
(if (caddr dest) (a ((href ,(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
"" (format "~a~a~a"
"#") (from-root (car dest)
(if (caddr dest) (get-dest-directory))
"" (if (caddr dest)
`(part ,(car (part-tags p))))))) ""
(class ,(if (eq? p mine) "#")
"tocviewselflink" (if (caddr dest)
"tocviewlink"))) ""
,@(render-content (part-title-content p) d ht))))) `(part ,(car (part-tags p)))))))
(part-parts top)))) (class ,(if (eq? p mine)
"tocviewselflink"
"tocviewlink")))
,@(render-content (part-title-content p) d ht))))))
(let loop ([l (map (lambda (v) (cons v #t)) (part-parts top))])
(cond
[(null? l) null]
[(reveal-subparts? (caar l))
(cons (car l) (loop (append (map (lambda (v) (cons v #f))
(part-parts (caar l)))
(cdr l))))]
[else (cons (car l) (loop (cdr l)))])))))
,@(if (ormap (lambda (p) (part-whole-page? p ht)) (part-parts d)) ,@(if (ormap (lambda (p) (part-whole-page? p ht)) (part-parts d))
null null
(let ([ps (cdr (let ([ps (cdr
@ -219,18 +241,26 @@
`(,@(if (and (not (part-title-content d)) `(,@(if (and (not (part-title-content d))
(null? number)) (null? number))
null null
`((,(case (length number) (if (and (styled-part? d)
[(0) 'h2] (let ([s (styled-part-style d)])
[(1) 'h3] (or (eq? s 'hidden)
[(2) 'h4] (and (list? s)
[else 'h5]) (memq 'hidden s)))))
,@(format-number number '((tt nbsp))) (map (lambda (t)
,@(map (lambda (t)
`(a ((name ,(format "~a" `(part ,t)))))) `(a ((name ,(format "~a" `(part ,t))))))
(part-tags d)) (part-tags d))
,@(if (part-title-content d) `((,(case (length number)
(render-content (part-title-content d) d ht) [(0) 'h2]
null)))) [(1) 'h3]
[(2) 'h4]
[else 'h5])
,@(format-number number '((tt nbsp)))
,@(map (lambda (t)
`(a ((name ,(format "~a" `(part ,t))))))
(part-tags d))
,@(if (part-title-content d)
(render-content (part-title-content d) d ht)
null)))))
,@(render-flow* (part-flow d) d ht #f) ,@(render-flow* (part-flow d) d ht #f)
,@(let loop ([pos 1] ,@(let loop ([pos 1]
[secs (part-parts d)]) [secs (part-parts d)])

57
collects/scribble/manual.ss
View File

@ -440,7 +440,7 @@
(define-syntax defthing (define-syntax defthing
(syntax-rules () (syntax-rules ()
[(_ id result desc ...) [(_ id result desc ...)
(*defthing (quote-syntax id) 'id 'result (lambda () (list desc ...)))])) (*defthing (quote-syntax id) 'id (quote-syntax result) (lambda () (list desc ...)))]))
(define-syntax defparam (define-syntax defparam
(syntax-rules () (syntax-rules ()
[(_ id arg contract desc ...) [(_ id arg contract desc ...)
@ -508,9 +508,15 @@
(cond (cond
[(pair? v) [(pair? v)
(if (keyword? (car v)) (if (keyword? (car v))
(make-element #f (list (to-element (car v)) (if (eq? mode 'new)
(hspace 1) (make-element #f (list (schemeparenfont "[")
(to-element (cadr v)))) (schemeidfont (keyword->string (car v)))
(hspace 1)
(to-element (cadr v))
(schemeparenfont "]")))
(make-element #f (list (to-element (car v))
(hspace 1)
(to-element (cadr v)))))
(to-element (car v)))] (to-element (car v)))]
[(eq? v '...+) [(eq? v '...+)
dots1] dots1]
@ -527,7 +533,8 @@
[(symbol? (car s)) (string-length (symbol->string (car s)))] [(symbol? (car s)) (string-length (symbol->string (car s)))]
[(pair? (car s)) [(pair? (car s))
(if (keyword? (caar s)) (if (keyword? (caar s))
(+ (string-length (keyword->string (caar s))) (+ (if (eq? mode 'new) 2 0)
(string-length (keyword->string (caar s)))
3 3
(string-length (symbol->string (cadar s)))) (string-length (symbol->string (cadar s))))
(string-length (symbol->string (caar s))))] (string-length (symbol->string (caar s))))]
@ -1236,7 +1243,7 @@
(define class-decls (make-hash-table 'equal)) (define class-decls (make-hash-table 'equal))
(define-struct decl (name super intfs body)) (define-struct decl (name super intfs mk-body))
(define-struct constructor (def)) (define-struct constructor (def))
(define-struct meth (mode desc def)) (define-struct meth (mode desc def))
(define-struct spec (def)) (define-struct spec (def))
@ -1251,20 +1258,20 @@
(define (*include-class name) (define (*include-class name)
(let ([decl (hash-table-get class-decls (register-scheme-definition name))]) (let ([decl (hash-table-get class-decls (register-scheme-definition name))])
(make-splice (make-splice
(cons (section (to-element (decl-name decl))) (cons (section #:style 'hidden (to-element (decl-name decl)))
(map (lambda (i) (map (lambda (i)
(cond (cond
[(constructor? i) ((constructor-def i))] [(constructor? i) ((constructor-def i))]
[(meth? i) [(meth? i)
((meth-def i) (meth-desc i))] ((meth-def i) (meth-desc i))]
[else i])) [else i]))
(decl-body decl)))))) ((decl-mk-body decl) #t))))))
(define-syntax include-class (define-syntax include-class
(syntax-rules () (syntax-rules ()
[(_ id) (*include-class (quote-syntax id))])) [(_ id) (*include-class (quote-syntax id))]))
(define (*defclass stx-id super intfs) (define (*defclass stx-id super intfs whole-page?)
(let ([spacer (hspace 1)]) (let ([spacer (hspace 1)])
(make-table (make-table
'boxed 'boxed
@ -1275,7 +1282,9 @@
(make-paragraph (make-paragraph
(list (let ([tag (register-scheme-definition stx-id)] (list (let ([tag (register-scheme-definition stx-id)]
[content (list (to-element stx-id))]) [content (list (to-element stx-id))])
(make-toc-target-element ((if whole-page?
make-page-target-element
make-toc-target-element)
#f #f
(list (make-index-element #f (list (make-index-element #f
content content
@ -1319,12 +1328,14 @@
(register-class (quote-syntax name) (register-class (quote-syntax name)
(quote-syntax super) (quote-syntax super)
(list (quote-syntax intf) ...) (list (quote-syntax intf) ...)
(append (lambda (whole-page?)
(list (append
(*defclass (quote-syntax name) (list
(quote-syntax super) (*defclass (quote-syntax name)
(list (quote-syntax intf) ...))) (quote-syntax super)
(list body ...))))])) (list (quote-syntax intf) ...)
whole-page?))
(list body ...)))))]))
(define-syntax definterface (define-syntax definterface
(syntax-rules () (syntax-rules ()
@ -1333,12 +1344,14 @@
(register-class (quote-syntax name) (register-class (quote-syntax name)
#f #f
(list (quote-syntax intf) ...) (list (quote-syntax intf) ...)
(append (lambda (whole-page?)
(list (append
(*defclass (quote-syntax name) (list
#f (*defclass (quote-syntax name)
(list (quote-syntax intf) ...))) #f
(list body ...))))])) (list (quote-syntax intf) ...)
whole-page?))
(list body ...)))))]))
(define-syntax (defconstructor*/* stx) (define-syntax (defconstructor*/* stx)
(syntax-case stx () (syntax-case stx ()

1
collects/scribble/struct.ss
View File

@ -74,6 +74,7 @@
[content list?])] [content list?])]
[(target-element element) ([tag tag?])] [(target-element element) ([tag tag?])]
[(toc-target-element target-element) ()] [(toc-target-element target-element) ()]
[(page-target-element target-element) ()]
[(link-element element) ([tag tag?])] [(link-element element) ([tag tag?])]
[(index-element element) ([tag tag?] [(index-element element) ([tag tag?]
[plain-seq (listof string?)] [plain-seq (listof string?)]