checkpoint GUI manual work
svn: r7117 original commit: c9f1aec9eb0491a6e80f5454815361a79c92618a
This commit is contained in:
Matthew Flatt
parent
6d55647707
commit
f45096ef94
|
|
@ -68,16 +68,27 @@
|
|||
(define/override (collect-target-element i ht)
|
||||
(hash-table-put! ht
|
||||
(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)
|
||||
(let-values ([(top mine)
|
||||
(let loop ([d d][mine d])
|
||||
(let ([p (collected-info-parent (part-collected-info d))])
|
||||
(if p
|
||||
(loop p d)
|
||||
(loop p (if (reveal-subparts? d)
|
||||
mine
|
||||
d))
|
||||
(values d mine))))])
|
||||
`((div ((class "tocset"))
|
||||
(div ((class "tocview"))
|
||||
|
|
@ -89,28 +100,39 @@
|
|||
(table
|
||||
((class "tocviewlist")
|
||||
(cellspacing "0"))
|
||||
,@(map (lambda (p)
|
||||
`(tr
|
||||
(td
|
||||
((align "right"))
|
||||
,@(format-number (collected-info-number (part-collected-info p))
|
||||
'((tt nbsp))))
|
||||
(td
|
||||
(a ((href ,(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
|
||||
(format "~a~a~a"
|
||||
(from-root (car dest)
|
||||
(get-dest-directory))
|
||||
(if (caddr dest)
|
||||
""
|
||||
"#")
|
||||
(if (caddr dest)
|
||||
""
|
||||
`(part ,(car (part-tags p)))))))
|
||||
(class ,(if (eq? p mine)
|
||||
"tocviewselflink"
|
||||
"tocviewlink")))
|
||||
,@(render-content (part-title-content p) d ht)))))
|
||||
(part-parts top))))
|
||||
,@(map (lambda (pp)
|
||||
(let ([p (car pp)]
|
||||
[show-number? (cdr pp)])
|
||||
`(tr
|
||||
(td
|
||||
((align "right"))
|
||||
,@(if show-number?
|
||||
(format-number (collected-info-number (part-collected-info p))
|
||||
'((tt nbsp)))
|
||||
'("-" nbsp)))
|
||||
(td
|
||||
(a ((href ,(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
|
||||
(format "~a~a~a"
|
||||
(from-root (car dest)
|
||||
(get-dest-directory))
|
||||
(if (caddr dest)
|
||||
""
|
||||
"#")
|
||||
(if (caddr dest)
|
||||
""
|
||||
`(part ,(car (part-tags p)))))))
|
||||
(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))
|
||||
null
|
||||
(let ([ps (cdr
|
||||
|
|
@ -219,18 +241,26 @@
|
|||
`(,@(if (and (not (part-title-content d))
|
||||
(null? number))
|
||||
null
|
||||
`((,(case (length number)
|
||||
[(0) 'h2]
|
||||
[(1) 'h3]
|
||||
[(2) 'h4]
|
||||
[else 'h5])
|
||||
,@(format-number number '((tt nbsp)))
|
||||
,@(map (lambda (t)
|
||||
(if (and (styled-part? d)
|
||||
(let ([s (styled-part-style d)])
|
||||
(or (eq? s 'hidden)
|
||||
(and (list? s)
|
||||
(memq 'hidden s)))))
|
||||
(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))))
|
||||
(part-tags d))
|
||||
`((,(case (length number)
|
||||
[(0) 'h2]
|
||||
[(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)
|
||||
,@(let loop ([pos 1]
|
||||
[secs (part-parts d)])
|
||||
|
|
|
|||
|
|
@ -440,7 +440,7 @@
|
|||
(define-syntax defthing
|
||||
(syntax-rules ()
|
||||
[(_ 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
|
||||
(syntax-rules ()
|
||||
[(_ id arg contract desc ...)
|
||||
|
|
@ -508,9 +508,15 @@
|
|||
(cond
|
||||
[(pair? v)
|
||||
(if (keyword? (car v))
|
||||
(make-element #f (list (to-element (car v))
|
||||
(hspace 1)
|
||||
(to-element (cadr v))))
|
||||
(if (eq? mode 'new)
|
||||
(make-element #f (list (schemeparenfont "[")
|
||||
(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)))]
|
||||
[(eq? v '...+)
|
||||
dots1]
|
||||
|
|
@ -527,7 +533,8 @@
|
|||
[(symbol? (car s)) (string-length (symbol->string (car s)))]
|
||||
[(pair? (car s))
|
||||
(if (keyword? (caar s))
|
||||
(+ (string-length (keyword->string (caar s)))
|
||||
(+ (if (eq? mode 'new) 2 0)
|
||||
(string-length (keyword->string (caar s)))
|
||||
3
|
||||
(string-length (symbol->string (cadar s))))
|
||||
(string-length (symbol->string (caar s))))]
|
||||
|
|
@ -1236,7 +1243,7 @@
|
|||
|
||||
(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 meth (mode desc def))
|
||||
(define-struct spec (def))
|
||||
|
|
@ -1251,20 +1258,20 @@
|
|||
(define (*include-class name)
|
||||
(let ([decl (hash-table-get class-decls (register-scheme-definition name))])
|
||||
(make-splice
|
||||
(cons (section (to-element (decl-name decl)))
|
||||
(cons (section #:style 'hidden (to-element (decl-name decl)))
|
||||
(map (lambda (i)
|
||||
(cond
|
||||
[(constructor? i) ((constructor-def i))]
|
||||
[(meth? i)
|
||||
((meth-def i) (meth-desc i))]
|
||||
[else i]))
|
||||
(decl-body decl))))))
|
||||
((decl-mk-body decl) #t))))))
|
||||
|
||||
(define-syntax include-class
|
||||
(syntax-rules ()
|
||||
[(_ id) (*include-class (quote-syntax id))]))
|
||||
|
||||
(define (*defclass stx-id super intfs)
|
||||
(define (*defclass stx-id super intfs whole-page?)
|
||||
(let ([spacer (hspace 1)])
|
||||
(make-table
|
||||
'boxed
|
||||
|
|
@ -1275,7 +1282,9 @@
|
|||
(make-paragraph
|
||||
(list (let ([tag (register-scheme-definition stx-id)]
|
||||
[content (list (to-element stx-id))])
|
||||
(make-toc-target-element
|
||||
((if whole-page?
|
||||
make-page-target-element
|
||||
make-toc-target-element)
|
||||
#f
|
||||
(list (make-index-element #f
|
||||
content
|
||||
|
|
@ -1319,12 +1328,14 @@
|
|||
(register-class (quote-syntax name)
|
||||
(quote-syntax super)
|
||||
(list (quote-syntax intf) ...)
|
||||
(append
|
||||
(list
|
||||
(*defclass (quote-syntax name)
|
||||
(quote-syntax super)
|
||||
(list (quote-syntax intf) ...)))
|
||||
(list body ...))))]))
|
||||
(lambda (whole-page?)
|
||||
(append
|
||||
(list
|
||||
(*defclass (quote-syntax name)
|
||||
(quote-syntax super)
|
||||
(list (quote-syntax intf) ...)
|
||||
whole-page?))
|
||||
(list body ...)))))]))
|
||||
|
||||
(define-syntax definterface
|
||||
(syntax-rules ()
|
||||
|
|
@ -1333,12 +1344,14 @@
|
|||
(register-class (quote-syntax name)
|
||||
#f
|
||||
(list (quote-syntax intf) ...)
|
||||
(append
|
||||
(list
|
||||
(*defclass (quote-syntax name)
|
||||
#f
|
||||
(list (quote-syntax intf) ...)))
|
||||
(list body ...))))]))
|
||||
(lambda (whole-page?)
|
||||
(append
|
||||
(list
|
||||
(*defclass (quote-syntax name)
|
||||
#f
|
||||
(list (quote-syntax intf) ...)
|
||||
whole-page?))
|
||||
(list body ...)))))]))
|
||||
|
||||
(define-syntax (defconstructor*/* stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -74,6 +74,7 @@
|
|||
[content list?])]
|
||||
[(target-element element) ([tag tag?])]
|
||||
[(toc-target-element target-element) ()]
|
||||
[(page-target-element target-element) ()]
|
||||
[(link-element element) ([tag tag?])]
|
||||
[(index-element element) ([tag tag?]
|
||||
[plain-seq (listof string?)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user