From f45096ef94cee5ed443a3a1157157f5a03a50fe1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Aug 2007 12:22:05 +0000 Subject: [PATCH] checkpoint GUI manual work svn: r7117 original commit: c9f1aec9eb0491a6e80f5454815361a79c92618a --- collects/scribble/html-render.ss | 100 ++++++++++++++++++++----------- collects/scribble/manual.ss | 57 +++++++++++------- collects/scribble/struct.ss | 1 + 3 files changed, 101 insertions(+), 57 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 0aad6228..e0957f5c 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -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)]) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 7a543152..0d9310bb 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -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 () diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index ff0b6c5f..10adbd82 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -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?)]