From 0c6734f782867b0401db15eb687fd246552e17b5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 11 Aug 2012 22:56:38 -0500 Subject: [PATCH] Add the contents of the "blue boxes" in the docs to the upper-right corner of the definitions window, based on the information that check syntax computes This commit contains two separate changes to make this work: - adding a new renderer, based on the text renderer, that pulls out the contents of the blue boxes and saves them in the doc/ directories (specifically in the files named contract-blueboxes.rktd) - extend check syntax to use and display the information build by the new renderer --- .../drracket/private/rectangle-intersect.rkt | 54 +- .../private/syncheck/contract-gui.rkt | 771 ++++++++++++++++++ collects/drracket/private/syncheck/gui.rkt | 59 +- .../drracket/private/syncheck/traversals.rkt | 3 +- collects/drracket/private/syncheck/xref.rkt | 1 + collects/scribble/base-render.rkt | 31 +- collects/scribble/contract-render.rkt | 182 +++++ collects/scribble/text-render.rkt | 7 +- .../scribblings/drracket/keybindings.scrbl | 7 + collects/scribblings/scribble/core.scrbl | 12 +- collects/scribblings/scribble/renderer.scrbl | 171 ++-- .../scribblings/scribble/struct-hierarchy.rkt | 10 +- collects/scribblings/scribble/xref.scrbl | 10 +- collects/setup/scribble.rkt | 32 +- collects/setup/setup-unit.rkt | 12 +- .../private/english-string-constants.rkt | 6 +- src/racket/src/schvers.h | 4 +- 17 files changed, 1242 insertions(+), 130 deletions(-) create mode 100644 collects/drracket/private/syncheck/contract-gui.rkt create mode 100644 collects/scribble/contract-render.rkt diff --git a/collects/drracket/private/rectangle-intersect.rkt b/collects/drracket/private/rectangle-intersect.rkt index ef0f318624..5d9327f29a 100644 --- a/collects/drracket/private/rectangle-intersect.rkt +++ b/collects/drracket/private/rectangle-intersect.rkt @@ -2,11 +2,53 @@ (provide rectangles-intersect?) (define (rectangles-intersect? l1 t1 r1 b1 l2 t2 r2 b2) - (or (point-in-rectangle? l1 t1 l2 t2 r2 b2) - (point-in-rectangle? r1 t1 l2 t2 r2 b2) - (point-in-rectangle? l1 b1 l2 t2 r2 b2) - (point-in-rectangle? r1 b1 l2 t2 r2 b2))) + (or (rectangles-intersect-one-way? l1 t1 r1 b1 l2 t2 r2 b2) + (rectangles-intersect-one-way? l2 t2 r2 b2 l1 t1 r1 b1))) -(define (point-in-rectangle? x y l t r b) +(define (rectangles-intersect-one-way? l1 t1 r1 b1 l2 t2 r2 b2) + (or (horizontal-segment-in-rectangle? l1 r1 t1 + l2 t2 r2 b2) + (horizontal-segment-in-rectangle? l1 r1 b1 + l2 t2 r2 b2) + (vertical-segment-in-rectangle? l1 t1 b1 + l2 t2 r2 b2) + (vertical-segment-in-rectangle? r1 t1 b1 + l2 t2 r2 b2))) + +(define (vertical-segment-in-rectangle? x y1 y2 l t r b) (and (<= l x r) - (<= t y b))) + (or (<= t y1 b) + (<= t y2 b) + (and (<= y1 t) + (<= b y2))))) + +(define (horizontal-segment-in-rectangle? x1 x2 y l t r b) + (and (<= t y b) + (or (<= l x1 r) + (<= l x2 r) + (and (<= x1 l) + (<= r x2))))) + +(module+ test + (require rackunit) + (check-equal? (rectangles-intersect? 0 0 10 10 + 2 2 8 8) + #t) + (check-equal? (rectangles-intersect? 2 2 8 8 + 0 0 10 10) + #t) + (check-equal? (rectangles-intersect? 0 0 10 10 + 0 0 10 10) + #t) + (check-equal? (rectangles-intersect? 10 10 20 20 + 0 15 30 17) + #t) + (check-equal? (rectangles-intersect? 0 15 30 17 + 10 10 20 20) + #t) + (check-equal? (rectangles-intersect? 0 0 10 10 + 20 20 40 40) + #f) + (check-equal? (rectangles-intersect? 0 0 10 10 + 25 0 27 10) + #f)) diff --git a/collects/drracket/private/syncheck/contract-gui.rkt b/collects/drracket/private/syncheck/contract-gui.rkt new file mode 100644 index 0000000000..07f6dc6108 --- /dev/null +++ b/collects/drracket/private/syncheck/contract-gui.rkt @@ -0,0 +1,771 @@ +#lang racket/base +(require framework + racket/gui/base + racket/class + racket/math + racket/runtime-path + data/interval-map + setup/dirs + images/icons/misc + "../rectangle-intersect.rkt" + string-constants) + +(provide docs-text-mixin + docs-editor-canvas-mixin + syncheck:add-docs-range + syncheck:reset-docs-im + syncheck:update-blue-boxes) + +(define sc-f2-to-lock (string-constant sc-f2-to-un/lock)) +(define sc-read-more... (string-constant sc-read-more...)) + +(preferences:set-default 'drracket:syncheck:contracts-locked? #f boolean?) + +(define corner-radius 48) +(define blue-box-color (make-object color% #xE8 #xE8 #xFF)) +(define var-color (make-object color% #x26 #x26 #x80)) +(define blue-box-margin 5) + +;; files->tag->offset : (listof (list file-path int hash[tag -o> (cons int int)])) +(define (fetch-files->tag->offset) + (filter + values + (for*/list ([doc-search-dir (in-list (get-doc-search-dirs))] + [doc-dir-name (in-list (if (directory-exists? doc-search-dir) + (directory-list doc-search-dir) + '()))]) + (define x (build-path doc-search-dir doc-dir-name "contract-blueboxes.rktd")) + (and (file-exists? x) + (call-with-input-file x + (λ (port) + (port-count-lines! port) + (define first-line (read-line port)) + (define pos (file-position port)) + (list x + (+ (string->number first-line) pos) + (read port)))))))) + +(define files->tag->offset #f) + +(define (fetch-strs tag) + (define plain-strs (fetch-strs-for-single-tag tag)) + (cond + [(and plain-strs + (pair? tag) + (eq? (car tag) 'def)) + (define constructor-strs + (fetch-strs-for-single-tag (cons 'construtor (cdr tag)))) + (if constructor-strs + (append plain-strs + '("") + ;; cdr drops the "white label" line (constructor, presumably) + (cdr constructor-strs)) + plain-strs)] + [else + plain-strs])) + +(define (fetch-strs-for-single-tag tag) + (unless files->tag->offset + (set! files->tag->offset (fetch-files->tag->offset))) + (for/or ([ent (in-list files->tag->offset)]) + (define offset+lens (hash-ref (list-ref ent 2) tag #f)) + (cond + [offset+lens + (apply + append + (for/list ([offset+len (in-list offset+lens)]) + (define fn (list-ref ent 0)) + (define offset (list-ref ent 1)) + (call-with-input-file fn + (λ (port) + (port-count-lines! port) + (file-position port (+ (car offset+len) offset)) + (for/list ([i (in-range (cdr offset+len))]) + (read-line port))))))] + [else #f]))) + +;; get-label-font : style-list -> number +;; the multiplication by 1.5 is suspicious, but it makes things +;; look right under mac os x (with fairly standard font settings) +(define (get-label-font sl) + (define style (send sl find-named-style "Standard")) + (define font-size (if style + (round (* #e1.5 (send (send style get-font) get-point-size))) + 18)) + (send the-font-list find-or-create-font + font-size 'swiss 'normal 'bold)) + +(define (get-read-more-font sl) + (define style (send sl find-named-style "Standard")) + (define font-size (if style + (send (send style get-font) get-point-size) + 12)) + (send the-font-list find-or-create-font + font-size 'roman 'italic 'normal)) +(define (get-read-more-underline-font sl) + (define style (send sl find-named-style "Standard")) + (define font-size (if style + (send (send style get-font) get-point-size) + 12)) + (send the-font-list find-or-create-font + font-size 'roman 'italic 'normal #t)) + +(define-local-member-name + get-show-docs? + get-current-strs + syncheck:reset-docs-im + syncheck:add-docs-range + syncheck:update-blue-boxes) + +(define docs-ec-clipping-region #f) +(define docs-ec-last-cw #f) +(define docs-ec-last-ch #f) +(define docs-ec-last-hi #f) +(define docs-ec-last-vi #f) + +(define (docs-editor-canvas-mixin %) + (class % + (inherit get-dc get-client-size get-editor + horizontal-inset vertical-inset) + (define/override (on-paint) + (define e (get-editor)) + (when e + (define dc (get-dc)) + (define-values (cw ch) (get-client-size)) + (define the-strs (send e get-current-strs)) + (cond + [(and (send e get-show-docs?) the-strs) + (define hi (horizontal-inset)) + (define vi (vertical-inset)) + (define font (send dc get-font)) + (define pen (send dc get-pen)) + (define brush (send dc get-brush)) + (define smoothing (send dc get-smoothing)) + (define std (send (send e get-style-list) find-named-style "Standard")) + (when std (send dc set-font (send std get-font))) + (define-values (box-width box-height label-overlap?) + (get-blue-box-size dc (send e get-style-list) the-strs)) + (send dc set-brush blue-box-color 'solid) + (send dc set-pen "black" 1 'transparent) + (send dc draw-rectangle (- cw box-width) 0 box-width box-height) + (send dc set-smoothing 'aligned) + + ;; most of the time (unless the user is + ;; resizing the window) we don't really + ;; need a new clipping region, so just + ;; make a cache of size 1, keyed by the + ;; client width, height, and vertical and + ;; horizontal insets. + (unless (and (equal? cw docs-ec-last-cw) + (equal? ch docs-ec-last-ch) + (equal? hi docs-ec-last-hi) + (equal? vi docs-ec-last-vi)) + (set! docs-ec-last-cw cw) + (set! docs-ec-last-ch ch) + (set! docs-ec-last-hi hi) + (set! docs-ec-last-vi vi) + (define rgn1 (new region%)) + (define rgn2 (new region%)) + (define rgn3 (new region%)) + (define rgn4 (new region%)) + (send rgn1 set-rectangle 0 0 cw vi) + (send rgn2 set-rectangle (- cw hi) 0 hi ch) + (send rgn3 set-rectangle 0 (- ch vi) cw vi) + (send rgn4 set-rectangle 0 0 hi ch) + (send rgn1 union rgn2) + (send rgn1 union rgn3) + (send rgn1 union rgn4) + (set! docs-ec-clipping-region rgn1)) + + (define old-region (send dc get-clipping-region)) + (send dc set-clipping-region docs-ec-clipping-region) + (draw-blue-box-shadow dc (- cw box-width) 0 box-width box-height) + + (send dc set-clipping-region old-region) + (send dc set-pen pen) + (send dc set-brush brush) + (send dc set-font font) + (send dc set-smoothing smoothing)] + [the-strs + (draw-closed dc cw 0)])) + (super on-paint)) + (super-new))) + +(define (docs-text-mixin %) + (class % + (inherit get-canvas get-admin get-style-list + dc-location-to-editor-location get-dc + get-start-position get-end-position) + + (define locked? (preferences:get 'drracket:syncheck:contracts-locked?)) + (define mouse-in-blue-box? #f) + (define mouse-in-lock-icon? #f) + (define mouse-in-read-more? #f) + + (define/public (get-show-docs?) (and the-strs (or locked? mouse-in-blue-box?))) + (define/public (toggle-syncheck-docs) + (when locked? + (set! mouse-in-blue-box? #f) + (define c (get-canvas)) + (when c (send c refresh))) + (update-locked (not locked?)) + (when last-evt-seen + (update-mouse-in-blue-box (in-blue-box? last-evt-seen)) + (define-values (is-in-lock? is-in-read-more?) (in-lock/in-read-more? last-evt-seen)) + (update-mouse-in-lock-icon/read-more? is-in-lock? is-in-read-more?))) + (define/public (update-mouse-in-blue-box b) + (unless (equal? b mouse-in-blue-box?) + (set! mouse-in-blue-box? b) + (define c (get-canvas)) + (when c (send c refresh)))) + (define/public (update-locked b) + (preferences:set 'drracket:syncheck:contracts-locked? b) + (unless (equal? b locked?) + (set! locked? b) + (define c (get-canvas)) + (when c (send c refresh)))) + (define/public (update-mouse-in-lock-icon/read-more? lk? rm?) + (unless (and (equal? lk? mouse-in-lock-icon?) + (equal? rm? mouse-in-read-more?)) + (set! mouse-in-lock-icon? lk?) + (set! mouse-in-read-more? rm?) + (define c (get-canvas)) + (when c (send c refresh)))) + + (define bx (box 0)) + (define by (box 0)) + (define bw (box 0)) + (define bh (box 0)) + + (define docs-im (make-interval-map)) + (define/public (syncheck:reset-docs-im) + (set! docs-im (make-interval-map)) + (define c (get-canvas)) + (when c (send c refresh))) + (define/public (syncheck:add-docs-range start end tag visit-docs-url) + ;; the +1 to end is effectively assuming that there + ;; are no abutting identifiers with documentation + (define rng (list start (+ end 1) tag visit-docs-url)) + (interval-map-set! docs-im start (+ end 1) rng) + (define c (get-canvas)) + (when c (send c refresh))) + + (define the-strs #f) + (define visit-docs-url void) + (define/public (get-current-strs) the-strs) + + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (super on-paint before? dc left top right bottom dx dy draw-caret) + (define-values (br bt bmp-x bmp-y) (get-box-upper-right-and-lock-coordinates)) + (when (and (not before?) br bt) + (define canvas (get-canvas)) + (define hi (send canvas horizontal-inset)) + (define vi (send canvas vertical-inset)) + (cond + [(get-show-docs?) + (draw-open dc dx dy + (get-style-list) + the-strs + br bt bmp-x bmp-y + mouse-in-blue-box? + mouse-in-lock-icon? + mouse-in-read-more? + locked? + + left top right bottom)] + [the-strs + (draw-closed dc (+ dx br) (+ dy bt))]))) + + ;; get-box-upper-right-and-lock-coordinates + ;; : (or/c (-> (values #f #f #f #f) + ;; (-> (values num num #f #f)) + ;; (-> (values num num num num))) + (define/private (get-box-upper-right-and-lock-coordinates) + (define admin (get-admin)) + (define canvas (get-canvas)) + (cond + [(and admin canvas) + (send admin get-view bx by bw bh) + (define hi (send canvas horizontal-inset)) + (define vi (send canvas vertical-inset)) + (define view-left (unbox bx)) + (define view-top (unbox by)) + (define br (+ view-left (unbox bw) hi)) + (define bt (+ view-top (- vi))) + (cond + [the-strs + (define-values (box-width box-height label-overlap?) + (get-blue-box-size (get-dc) (get-style-list) the-strs)) + (define bmp-bluebox-x (+ br (- blue-box-margin box-width))) + (define bmp-bluebox-y (+ bt (- box-height blue-box-margin lock-height))) + (define view-bottom (+ view-top (unbox bh))) + (define bmp-view-x (+ view-left blue-box-margin)) + (define bmp-view-y (- view-bottom blue-box-margin lock-height)) + (cond + [(or (bmp-bluebox-x . <= . bmp-view-x) + (bmp-bluebox-y . >= . bmp-view-y)) + (values br bt bmp-view-x bmp-view-y)] + [else + (values br bt bmp-bluebox-x bmp-bluebox-y)])] + [else + (values br bt #f #f)])] + [else (values #f #f #f #f)])) + + (define/override (adjust-cursor evt) + (cond + [(in-blue-box? evt) + arrow-cursor] + [else + (super adjust-cursor evt)])) + + (define last-evt-seen #f) + (define/override (on-event evt) + (set! last-evt-seen evt) + (update-mouse-in-blue-box (in-blue-box? evt)) + (define-values (is-in-lock? is-in-read-more?) (in-lock/in-read-more? last-evt-seen)) + (update-mouse-in-lock-icon/read-more? is-in-lock? is-in-read-more?) + (cond + [mouse-in-blue-box? + (cond + [(and mouse-in-lock-icon? + (send evt button-up? 'left)) + (update-locked (not locked?))] + [(and mouse-in-read-more? + (send evt button-up? 'left)) + (visit-docs-url)])] + [else + (super on-event evt)])) + + (define/augment (after-set-position) + (inner (void) after-set-position) + (update-the-strs)) + + (define/public (syncheck:update-blue-boxes) + (update-the-strs)) + + (define/private (update-the-strs) + (define sp (get-start-position)) + (when (= sp (get-end-position)) + (define tag+rng (interval-map-ref docs-im sp #f)) + (when tag+rng + (define tag (list-ref tag+rng 2)) + (define new-visit-docs-url (list-ref tag+rng 3)) + (define new-strs (fetch-strs tag)) + (when new-strs + (set! the-strs new-strs) + (set! visit-docs-url new-visit-docs-url) + (when last-evt-seen + (update-mouse-in-blue-box (in-blue-box? last-evt-seen)) + (define-values (is-in-lock? is-in-read-more?) (in-lock/in-read-more? last-evt-seen)) + (update-mouse-in-lock-icon/read-more? is-in-lock? is-in-read-more?)) + (define c (get-canvas)) + (when c (send c refresh)))))) + + (define/augment (after-insert where len) + (inner (void) after-insert where len) + (clear-im-range where len) + (interval-map-expand! docs-im where (+ where len)) + (possibly-reset-strs-gui)) + + (define/augment (after-delete where len) + (inner (void) after-delete where len) + (clear-im-range where len) + (interval-map-contract! docs-im where (+ where len)) + (possibly-reset-strs-gui)) + + (define/private (possibly-reset-strs-gui) + (let ([old-strs the-strs]) + (set! the-strs #f) + (set! visit-docs-url void) + (update-the-strs) + (unless (equal? old-strs the-strs) + (define c (get-canvas)) + (when c (send c refresh))))) + + (define/private (clear-im-range where len) + (for ([x (in-range len)]) + (define tag+rng (interval-map-ref docs-im (+ where x) #f)) + (when tag+rng + (interval-map-remove! + docs-im + (list-ref tag+rng 0) + (list-ref tag+rng 1))))) + + (define/private (in-blue-box? evt) + (cond + [(send evt leaving?) #f] + [else + (define dc-x (send evt get-x)) + (define dc-y (send evt get-y)) + (define-values (br bt bmp-x bmp-y) (get-box-upper-right-and-lock-coordinates)) + (cond + [(and br bt the-strs) + (define-values (ex ey) (dc-location-to-editor-location dc-x dc-y)) + (define-values (bw bh _) + (if (get-show-docs?) + (get-blue-box-size (get-dc) (get-style-list) the-strs) + (values corner-radius corner-radius #f))) + (and (<= (- br bw) ex br) + (<= bt ey (+ bt bh)))] + [else #f])])) + + (define/private (in-lock/in-read-more? evt) + (cond + [(send evt leaving?) (values #f #f)] + [(get-show-docs?) + (define dc-x (send evt get-x)) + (define dc-y (send evt get-y)) + (define-values (br bt bmp-x bmp-y) (get-box-upper-right-and-lock-coordinates)) + + (define-values (read-more-w read-more-h read-more-d read-more-a) + (send (get-dc) get-text-extent sc-read-more... + (get-read-more-underline-font (get-style-list)))) + + (cond + [(and br bt bmp-x bmp-y) + (define-values (ex ey) (dc-location-to-editor-location dc-x dc-y)) + (values (and (<= bmp-x ex (+ bmp-x lock-width)) + (<= bmp-y ey (+ bmp-y lock-height))) + (and (<= (- br read-more-w read-more-gap) ex (- br read-more-gap)) + (<= (+ bmp-y lock-height (- read-more-h)) + ey + (+ bmp-y lock-height))))] + [else (values #f #f)])] + [else (values #f #f)])) + + (super-new))) + +(define arrow-cursor (make-object cursor% 'arrow)) + +(define (make-arrow-path init-angle) + (struct turtle (x y θ)) + + (define (move-then-turn p dist α) + (define x (turtle-x p)) + (define y (turtle-y p)) + (define θ (turtle-θ p)) + (turtle (+ x (* dist (cos θ))) + (+ y (* dist (sin θ))) + (+ α θ))) + + (define arrow-tail-length 12) + (define arrow-tail-width 8) + (define arrow-head-side-len 24) + + ;; start at the center of the end of the arrow + (define p1 (turtle 0 0 init-angle)) + (define p2 (move-then-turn p1 (/ arrow-tail-width 2) (/ pi 2))) + (define p3 (move-then-turn p2 arrow-tail-length (- (/ pi 2)))) + (define p4 (move-then-turn p3 + (- (/ arrow-head-side-len 2) (/ arrow-tail-width 2)) + (* pi 2/3))) + (define p5 (move-then-turn p4 arrow-head-side-len (* pi 2/3))) + (define p6 (move-then-turn p5 arrow-head-side-len (* pi 2/3))) + (define p7 (move-then-turn p6 + (- (/ arrow-head-side-len 2) (/ arrow-tail-width 2)) + (- (/ pi 2)))) + (define p8 (move-then-turn p7 arrow-tail-length (/ pi 2))) + (define p9 (move-then-turn p8 (/ arrow-tail-width 2) 0)) + + (define dc-path (new dc-path%)) + (send dc-path move-to (turtle-x p1) (turtle-y p1)) + (for ([p (in-list (list p2 p3 p4 p5 p6 p7 p8 p9))]) + (send dc-path line-to (turtle-x p) (turtle-y p))) + (send dc-path close) + dc-path) + +(define open-arrow-path (make-arrow-path (* pi 1/4))) +(define lock-closed (lock-icon #f)) +(define lock-open (lock-icon #t)) +(define lock-width (max (send lock-closed get-width) + (send lock-open get-width))) +(define lock-height (max (send lock-closed get-height) + (send lock-open get-height))) + +(define (draw-closed dc x y) + (define smoothing (send dc get-smoothing)) + (define pen (send dc get-pen)) + (define brush (send dc get-brush)) + + (send dc set-pen "black" 1 'transparent) + (send dc set-smoothing 'aligned) + + (define-values (ox oy) (send dc get-origin)) + (send dc set-origin + (+ ox x (- corner-radius) (- shadow-size)) + (+ oy y (- corner-radius) (- shadow-size))) + (send dc set-brush closed-radial-gradient-brush) + (send dc draw-arc + 0 0 + (* (+ corner-radius shadow-size) 2) + (* (+ corner-radius shadow-size) 2) + pi (* pi #e1.5)) + (send dc set-origin ox oy) + + (send dc set-brush blue-box-color 'solid) + (send dc draw-arc + (- x corner-radius 1) (- y corner-radius 1) + (+ (* corner-radius 2) 2) (+ (* corner-radius 2) 2) + pi (* pi #e1.5)) + + (send dc set-brush "white" 'solid) + (send dc draw-path open-arrow-path (- x 6) (+ y 6)) + + (send dc set-smoothing smoothing) + (send dc set-brush brush) + (send dc set-pen pen)) + +(define fade-out-color (make-object color% 255 255 255 .8)) + +(define (draw-open dc dx dy + sl strs + br bt bmp-x bmp-y + show-lock? mouse-in-lock-icon? mouse-in-read-more? locked? + left top right bottom) + + + (define-values (box-width box-height label-overlap?) + (get-blue-box-size dc sl strs)) + + (when (let* ([wd-left (- br box-width shadow-size)] + [wd-top bt] + [wd-right (+ wd-left box-width shadow-size)] + [wd-bottom (+ wd-top box-height shadow-size)]) + ;; wd for "will draw" + (rectangles-intersect? wd-left wd-top wd-right wd-bottom + left top right bottom)) + + (define dx+br (+ dx br)) + (define dy+bt (+ dy bt)) + (define pen (send dc get-pen)) + (define brush (send dc get-brush)) + (define smoothing (send dc get-smoothing)) + (define text-foreground (send dc get-text-foreground)) + (define font (send dc get-font)) + + (define std (send sl find-named-style "Standard")) + (when std (send dc set-font (send std get-font))) + + (send dc set-smoothing 'aligned) + (send dc set-brush blue-box-color 'solid) + (send dc set-pen "black" 1 'transparent) + (send dc draw-rectangle + (+ dx (- br box-width)) + (+ dy bt) + box-width + box-height) + + (send dc set-font (if mouse-in-read-more? + (get-read-more-underline-font sl) + (get-read-more-font sl))) + (define-values (read-more-w read-more-h read-more-d read-more-a) + (send dc get-text-extent sc-read-more... (get-read-more-underline-font sl))) + (send dc draw-text + sc-read-more... + (+ dx (- br read-more-w read-more-gap)) + (+ dy (- (+ bmp-y lock-height) read-more-h))) + + (when show-lock? + (define icon (if locked? lock-closed lock-open)) + (send dc draw-bitmap icon (+ dx bmp-x) (+ dy bmp-y)) + (when mouse-in-lock-icon? + (send dc set-font normal-control-font) + (send dc set-text-foreground "black") + (define-values (tw th _1 _2) (send dc get-text-extent sc-f2-to-lock)) + (send dc set-brush fade-out-color 'solid) + (define txt-x (- dx+br box-width)) + (define txt-y (+ dy+bt box-height)) + (send dc draw-rectangle + txt-x txt-y + (+ tw 8) + (+ th 4)) + (send dc draw-text sc-f2-to-lock + (+ txt-x 4) + (+ txt-y 2)))) + + (when std (send dc set-font (send std get-font))) + (define label-font (get-label-font sl)) + (define-values (label-w label-h label-d label-a) + (send dc get-text-extent (list-ref strs 0) label-font)) + (define-values (first-line-w first-line-h _1 _2) + (send dc get-text-extent (if (null? (cdr strs)) "" (list-ref strs 1)))) + + (send dc set-text-foreground var-color) + (for/fold ([y (if label-overlap? + (+ blue-box-margin (extra-first-line-space dc sl strs)) + (+ blue-box-margin label-h))]) + ([str (in-list (cdr strs))]) + (define-values (w h d a) (send dc get-text-extent str)) + (send dc draw-text str (+ (- dx+br box-width) blue-box-margin) (+ dy+bt y)) + (+ y h)) + + (draw-blue-box-shadow dc (- dx+br box-width) dy+bt box-width box-height) + + (send dc set-text-foreground "white") + (send dc set-font label-font) + (send dc draw-text (list-ref strs 0) + (- dx+br blue-box-margin label-w) + (+ dy+bt blue-box-margin)) + + (send dc set-text-foreground text-foreground) + (send dc set-smoothing smoothing) + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font))) + +;; EFFECT: updates the pen & brush of the given dc (but restores origin) +(define (draw-blue-box-shadow dc box-x box-y box-width box-height) + + (define-values (ox oy) (send dc get-origin)) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush horizontal-gradient-brush) + (send dc set-origin + (+ ox (- box-x shadow-size)) + (+ oy box-y)) + (send dc draw-rectangle 0 0 shadow-size box-height) + + (send dc set-brush vertical-gradient-brush) + (send dc set-origin + (+ ox box-x) + (+ oy (+ box-y box-height))) + (send dc draw-rectangle 0 0 box-width shadow-size) + + (send dc set-brush radial-gradient-brush) + (send dc set-origin + (+ ox (- box-x shadow-size)) + (+ oy (- (+ box-y box-height) shadow-size))) + (send dc draw-arc + 0 0 + (* 2 shadow-size) + (* 2 shadow-size) + pi + (* pi 3/2)) + (send dc set-origin ox oy)) + +(define shadow-start-color (make-object color% 0 0 0 .5)) +(define shadow-end-color (make-object color% 0 0 0 0)) +(define shadow-size 10) + +(define horizontal-gradient-brush + (new brush% + [gradient + (new linear-gradient% + [x0 0] [y0 0] + [x1 shadow-size] [y1 0] + [stops (list (list 0 shadow-end-color) + (list 1 shadow-start-color))])])) +(define vertical-gradient-brush + (new brush% + [gradient + (new linear-gradient% + [x0 0] [y0 0] + [x1 0] [y1 shadow-size] + [stops (list (list 0 shadow-start-color) + (list 1 shadow-end-color))])])) +(define radial-gradient-brush + (new brush% + [gradient + (new radial-gradient% + [x0 shadow-size] [y0 shadow-size] [r0 0] + [x1 shadow-size] [y1 shadow-size] [r1 shadow-size] + [stops (list (list 0 shadow-start-color) + (list 1 shadow-end-color))])])) + +(define closed-radial-gradient-brush + (new brush% + [gradient + (new radial-gradient% + [x0 (+ corner-radius shadow-size)] [y0 (+ corner-radius shadow-size)] [r0 corner-radius] + [x1 (+ corner-radius shadow-size)] [y1 (+ corner-radius shadow-size)] [r1 (+ shadow-size corner-radius)] + [stops (list (list 0 (make-object color% 0 0 0 0)) + (list 0 shadow-start-color) + (list 1 shadow-end-color))])])) + +(define (get-blue-box-size dc sl strs) + (define std-font + (and (send sl find-named-style "Standard") + (send (send sl find-named-style "Standard") get-font))) + (define-values (main-w main-h) + (for/fold ([tot-w (+ blue-box-margin blue-box-margin)] + [tot-h (+ blue-box-margin blue-box-margin)]) + ([str (in-list (cdr strs))]) + (define-values (w h d a) (send dc get-text-extent str std-font)) + (values (max tot-w (+ w blue-box-margin blue-box-margin)) + (+ tot-h h)))) + (define-values (label-w label-h _2 _3) + (send dc get-text-extent (list-ref strs 0) (get-label-font sl))) + (define-values (first-line-w first-line-h _5 _6) + (send dc get-text-extent + (if (null? (cdr strs)) "" (list-ref strs 1)) + std-font)) + (define-values (read-more-w read-more-h _7 _8) + (send dc get-text-extent + sc-read-more... + (get-read-more-underline-font sl))) + (cond + [(<= (+ label-w first-line-w 10) main-w) + ;; in this case, there is no overlap on the first line, so + ;; we draw both on the first line (like they are drawn in the html) + (values main-w + (+ main-h + (extra-first-line-space dc sl strs) + read-more-h + read-more-gap) + #t)] + [else + ;; otherwise we make an extra line at the top for the first line + (values (max main-w label-w) + (+ main-h label-h read-more-h read-more-gap) + #f)])) + +(define read-more-gap 4) + +;; returns the extra gap to leave above the first line of the contract +;; so that the baseline of the label and the baseline of that first line +;; are at the same place (useful in the case where the label overlaps +;; with the first line of the contract) +(define (extra-first-line-space dc sl strs) + (define-values (_1 label-h label-d _2) + (send dc get-text-extent (list-ref strs 0) (get-label-font sl))) + (define-values (_3 first-line-h first-line-d _4) + (send dc get-text-extent (if (null? (cdr strs)) "" (list-ref strs 1)))) + (max 0 (- (- label-h label-d) + (- first-line-h first-line-d)))) + +(module+ main + (begin + (require racket/runtime-path) + (define f2-docs-keybinding "f2 docs") + (define k (new keymap%)) + (send k add-function f2-docs-keybinding + (λ (txt evt) + (send txt toggle-syncheck-docs))) + (send k map-function "f2" f2-docs-keybinding) + (define-runtime-path unit-docs.rktd "unit-docs.rktd") + (define unit-docs + (call-with-input-file unit-docs.rktd + (λ (port) + (let loop () + (define expr (read port)) + (if (eof-object? expr) + '() + (cons expr (loop))))))) + (define f (if (eq? (system-type) 'macosx) + (new frame% [width 600] [height 800] [label ""] [x 400]) + (new frame% [width 600] [height 750] [label ""]))) + (define t (new (docs-text-mixin scheme:text%))) + (void (send t load-file (collection-file-path "unit.rkt" "drracket" "private"))) + (send t set-keymap k) + (define ec (new (docs-editor-canvas-mixin editor-canvas%) [parent f] [editor t])) + + (require racket/match) + (time + (begin + (for ([line (in-list unit-docs)]) + (match-define `(,start ,end ,tag) line) + (send t syncheck:add-docs-range start end tag (λ () (printf "visit docs url ~s\n" tag)))) + (printf "add-docs-range: "))) + + (send f show #t)) + + #;(fetch-strs '(form ((lib "racket/private/class-internal.rkt") class)))) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 613eacca8e..ed59ee992f 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -47,7 +47,8 @@ If the namespace does not, they are colored the unbound color. "colors.rkt" "traversals.rkt" "annotate.rkt" - "../tooltip.rkt") + "../tooltip.rkt" + "contract-gui.rkt") (provide tool@) (define orig-output-port (current-output-port)) @@ -327,13 +328,14 @@ If the namespace does not, they are colored the unbound color. (define make-syncheck-text% (λ (super%) (let* ([cursor-arrow (make-object cursor% 'arrow)]) - (class* super% (syncheck-text<%>) + (class* (docs-text-mixin super%) (syncheck-text<%>) (inherit set-cursor get-admin invalidate-bitmap-cache set-position get-pos/text get-pos/text-dc-location position-location get-canvas last-position dc-location-to-editor-location find-position begin-edit-sequence end-edit-sequence highlight-range unhighlight-range - paragraph-end-position first-line-currently-drawn-specially?) + paragraph-end-position first-line-currently-drawn-specially? + syncheck:add-docs-range) ;; arrow-records : (U #f hash[text% => arrow-record]) ;; arrow-record = interval-map[(listof arrow-entry)] @@ -581,7 +583,21 @@ If the namespace does not, they are colored the unbound color. (void)) (syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file))) - (define/public (syncheck:add-docs-menu text start-pos end-pos id the-label path tag) + (define/public (syncheck:add-docs-menu text start-pos end-pos id the-label path definition-tag tag) + (define (visit-docs-url) + (define url (path->url path)) + (define url2 (if tag + (make-url (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (url-path url) + (url-query url) + tag) + url)) + (send-url (url->string url2))) + (syncheck:add-docs-range start-pos end-pos definition-tag visit-docs-url) (syncheck:add-menu text start-pos end-pos id (λ (menu) @@ -590,18 +606,7 @@ If the namespace does not, they are colored the unbound color. (label (gui-utils:format-literal-label "~a" the-label)) (callback (λ (x y) - (let* ([url (path->url path)] - [url2 (if tag - (make-url (url-scheme url) - (url-user url) - (url-host url) - (url-port url) - (url-path-absolute? url) - (url-path url) - (url-query url) - tag) - url)]) - (send-url (url->string url2))))))))) + (visit-docs-url))))))) (define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?) (define (make-menu menu) @@ -1067,7 +1072,7 @@ If the namespace does not, they are colored the unbound color. ;; If this were done more directly, the tooltip would show up in ;; the wrong canvas half the time - when the current admin isn't ;; the admin for the canvas the mouse is over. - (invalidate-bitmap-cache)) + (invalidate-bitmap-cache 0 0 'display-end 'display-end)) (define/public (syncheck:build-popup-menu pos text) (and pos @@ -1576,7 +1581,8 @@ If the namespace does not, they are colored the unbound color. ;; reset any previous check syntax information (let ([tab (get-current-tab)]) (send tab syncheck:clear-error-message) - (send tab syncheck:clear-highlighting)) + (send tab syncheck:clear-highlighting) + (send defs-text syncheck:reset-docs-im)) (send (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running) (send defs-text syncheck:init-arrows) @@ -1584,6 +1590,7 @@ If the namespace does not, they are colored the unbound color. [i 0]) (cond [(null? val) + (send defs-text syncheck:update-blue-boxes) (send defs-text syncheck:update-drawn-arrows) (send (send defs-text get-tab) remove-bkg-running-color 'syncheck) (set-syncheck-running-mode #f)] @@ -1618,8 +1625,8 @@ If the namespace does not, they are colored the unbound color. (send defs-text syncheck:add-jump-to-definition defs-text start end id filename)] [`(syncheck:add-require-open-menu ,text ,start-pos ,end-pos ,file) (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)] - [`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,tag) - (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path tag)] + [`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag) + (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)] [`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) (define other-side-dead? #f) (define (name-dup? name) @@ -2016,7 +2023,12 @@ If the namespace does not, they are colored the unbound color. (send keymap map-function "c:c;c:c" "check syntax") (send keymap map-function "c:x;b" "jump to binding occurrence") (send keymap map-function "c:x;n" "jump to next bound occurrence") - (send keymap map-function "c:x;d" "jump to definition (in other file)")) + (send keymap map-function "c:x;d" "jump to definition (in other file)") + + (send keymap add-function "f2 docs" + (λ (txt evt) + (send txt toggle-syncheck-docs))) + (send keymap map-function "f2" "f2 docs")) ;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>)) (define (find-syncheck-text text) @@ -2053,15 +2065,16 @@ If the namespace does not, they are colored the unbound color. syncheck-add-to-preferences-panel) (drracket:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t) (drracket:get/extend:extend-definitions-text make-syncheck-text%) + (drracket:get/extend:extend-definitions-canvas docs-editor-canvas-mixin) (drracket:get/extend:extend-unit-frame unit-frame-mixin #f) (drracket:get/extend:extend-tab tab-mixin) (drracket:module-language-tools:add-online-expansion-handler - compile-comp.rkt + online-comp.rkt 'go (λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window) replay-compile-comp-trace defs-text val))))) -(define-runtime-path compile-comp.rkt "online-comp.rkt") +(define-runtime-path online-comp.rkt "online-comp.rkt") diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index 865fbf22c7..c075c3000c 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -972,7 +972,7 @@ (when source-editor (define info (get-index-entry-info binding-info)) (when info - (define-values (entry-desc path tag) (apply values info)) + (define-values (entry-desc path definition-tag tag) (apply values info)) (send defs-text syncheck:add-background-color source-editor start fin "palegreen") @@ -983,6 +983,7 @@ (syntax-e stx) (build-docs-label entry-desc) path + definition-tag tag)))))) (define (build-docs-label entry-desc) diff --git a/collects/drracket/private/syncheck/xref.rkt b/collects/drracket/private/syncheck/xref.rkt index fbddbb3054..15a5a0833f 100644 --- a/collects/drracket/private/syncheck/xref.rkt +++ b/collects/drracket/private/syncheck/xref.rkt @@ -35,6 +35,7 @@ (and index-entry (list (entry-desc index-entry) path + definition-tag tag)))))))))) (thread (λ () diff --git a/collects/scribble/base-render.rkt b/collects/scribble/base-render.rkt index 99a10c656c..b112289b10 100644 --- a/collects/scribble/base-render.rkt +++ b/collects/scribble/base-render.rkt @@ -11,10 +11,37 @@ file/convertible "render-struct.rkt") -(provide render%) +(provide render% + render<%>) + +(define render<%> + (interface () + traverse + collect + resolve + render + serialize-info + deserialize-info + get-external + get-undefined + + ;; undocumented: + current-render-mode + get-substitutions + render-part + render-flow + render-intrapara-block + render-table + render-itemization + render-paragraph + render-content + render-nested-flow + render-block + render-other + get-dest-directory)) (define render% - (class object% + (class* object% (render<%>) (init-field dest-dir [refer-to-existing-files #f] diff --git a/collects/scribble/contract-render.rkt b/collects/scribble/contract-render.rkt new file mode 100644 index 0000000000..159af0cabf --- /dev/null +++ b/collects/scribble/contract-render.rkt @@ -0,0 +1,182 @@ +#lang racket/base +(require racket/class racket/match + (prefix-in text: "text-render.rkt") + "base-render.rkt" + "core.rkt" + (only-in slideshow/pict pict?) + file/convertible) +(provide override-render-mixin-single + override-render-mixin-multi) + +(define (override-render-mixin multi?) + (mixin (render<%>) () + (super-new) + (define/override (render srcs dests ri) + (super render srcs dests ri) + + (for ([part (in-list srcs)] + [dest (in-list dests)]) + (define p (open-output-string)) + (define index-table (make-hash)) + (port-count-lines! p) + (parameterize ([the-renderer text-renderer] + [the-part part] + [the-ri ri] + [the-text-p p]) + (r-part part 'block index-table)) + (define table-str (format "~s\n" index-table)) + (define cb.rktd + (cond + [multi? + (build-path dest "contract-blueboxes.rktd")] + [else + (define-values (base name dir?) (split-path dest)) + (build-path base "contract-blueboxes.rktd")])) + (call-with-output-file cb.rktd + (λ (port) + (fprintf port "~a\n" (string-utf-8-length table-str)) + (display table-str port) + (display (get-output-string p) port)) + #:exists 'truncate))) + + (inherit get-dest-directory) + (define text-renderer (new (text:render-mixin render%) + [dest-dir (get-dest-directory)])))) + +(define the-renderer (make-parameter #f)) +(define the-part (make-parameter #f)) +(define the-ri (make-parameter #f)) +(define the-text-p (make-parameter #f)) + +;; mode is either +;; 'block -- search for the blue blocks +;; or (cons number number) -- search for tags in a block +(define (r-parts parts mode index-table) + (for ([part (in-list parts)]) + (r-part part mode index-table))) + +(define (r-part part mode index-table) + (r-blocks (part-blocks part) mode index-table) + (r-parts (part-parts part) mode index-table)) + +(define (r-blocks blocks mode index-table) + (for ([block (in-list blocks)]) + (r-block block mode index-table))) + +(define (r-block block mode index-table) + (match block + [(struct nested-flow (style blocks)) + (check-and-continue style block mode index-table r-blocks blocks)] + [(struct compound-paragraph (style blocks)) + (check-and-continue style block mode index-table r-blocks blocks)] + [(paragraph style content) + (check-and-continue style block mode index-table r-content content)] + [(itemization style blockss) + (check-and-continue style block mode index-table r-blockss blockss)] + [(table style cells) + (check-and-continue style block mode index-table r-blockss+cont cells)] + [(delayed-block resolve) + (r-block (delayed-block-blocks block (the-ri)) mode index-table)])) + +(define (check-and-continue style block mode index-table sub-f sub-p) + (cond + [(and (pair? mode) (equal? (style-name style) "RBackgroundLabelInner")) + (define background-label-port (car mode)) + (parameterize ([current-output-port background-label-port]) + (send (the-renderer) render-block block (the-part) (the-ri) #f)) + (sub-f sub-p mode index-table)] + [(and (eq? mode 'block) (eq? (style-name style) 'boxed) (table? block)) + (cond + [(for/and ([cells (in-list (table-blockss block))]) + (and (not (null? cells)) + (null? (cdr cells)) + (let ([fst (car cells)]) + (and (table? fst) + (equal? (style-name (table-style fst)) "together"))))) + (for ([cells (in-list (table-blockss block))]) + (handle-one-block style (car cells) mode index-table r-block (car cells)))] + [else + (handle-one-block style block mode index-table sub-f sub-p)])] + [else + (sub-f sub-p mode index-table)])) + +(define (handle-one-block style block mode index-table sub-f sub-p) + ;(printf "-----\n") ((dynamic-require 'racket/pretty 'pretty-write) block) + (define block-port (open-output-string)) + (define background-label-port (open-output-string)) + (define ents (make-hash)) + (define new-mode (cons background-label-port ents)) + (port-count-lines! block-port) + (port-count-lines! background-label-port) + (parameterize ([current-output-port block-port]) + (send (the-renderer) render-block block (the-part) (the-ri) #f)) + (sub-f sub-p new-mode index-table) + + ;; we just take the first one here + (define background-label-p (open-input-string (get-output-string background-label-port))) + (define background-label-line (read-line background-label-p)) + + (define text-p (the-text-p)) + (define-values (before-line _1 _2) (port-next-location text-p)) + (define before-position (file-position text-p)) + (fprintf text-p "~a\n" + (if (eof-object? background-label-line) + "" + background-label-line)) + + ;; dump content of block-port into text-p, but first trim + ;; the spaces that appear at the ends of the lines + (let ([p (open-input-string (get-output-string block-port))]) + (let loop () + (define l (read-line p)) + (unless (eof-object? l) + (display (regexp-replace #rx" *$" l "") text-p) + (newline text-p) + (loop)))) + + (define-values (after-line _3 _4) (port-next-location text-p)) + (define txt-loc (cons before-position (- after-line before-line))) + (for ([(k v) (in-hash ents)]) + (hash-set! index-table k (cons txt-loc (hash-ref index-table k '()))))) + +(define (r-blockss+cont blockss mode index-table) + (for ([blocks (in-list blockss)]) + (for ([block (in-list blocks)]) + (unless (eq? block 'cont) + (r-block block mode index-table))))) + +(define (r-blockss blockss mode index-table) + (for ([blocks (in-list blockss)]) + (r-blocks blocks mode index-table))) + +(define (r-content content mode index-table) + (cond + [(element? content) (r-element content mode index-table)] + [(list? content) + (for ([content (in-list content)]) + (r-content content mode index-table))] + [(string? content) (void)] + [(symbol? content) (void)] + [(pict? content) (void)] + [(convertible? content) (void)] + [(delayed-element? content) + (r-content (delayed-element-content content (the-ri)) mode index-table)] + [(traverse-element? content) + (r-content (traverse-element-content content (the-ri)) mode index-table)] + [(part-relative-element? content) + (r-content (part-relative-element-content content (the-ri)) mode index-table)] + [(multiarg-element? content) + (r-content (multiarg-element-contents content) mode index-table)] + [else (error 'r-content "unknown content: ~s\n" content)])) + +(define (r-element element mode index-table) + (when (index-element? element) + (when (pair? mode) + (define ents (cdr mode)) + (define key (index-element-tag element)) + (hash-set! ents key #t))) + (r-content (element-content element) mode index-table)) + + +(define override-render-mixin-multi (override-render-mixin #t)) +(define override-render-mixin-single (override-render-mixin #f)) diff --git a/collects/scribble/text-render.rkt b/collects/scribble/text-render.rkt index c5baffd0d1..e4650a5a1b 100644 --- a/collects/scribble/text-render.rkt +++ b/collects/scribble/text-render.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require "core.rkt" racket/class racket/port racket/list racket/string +(require "core.rkt" "base-render.rkt" + racket/class racket/port racket/list racket/string scribble/text/wrap) (provide render-mixin) @@ -15,8 +16,8 @@ (newline) (indent)) -(define (render-mixin %) - (class % +(define render-mixin + (mixin (render<%>) () (define/override (current-render-mode) '(text)) diff --git a/collects/scribblings/drracket/keybindings.scrbl b/collects/scribblings/drracket/keybindings.scrbl index f6f1629d1d..45b8a68ee7 100644 --- a/collects/scribblings/drracket/keybindings.scrbl +++ b/collects/scribblings/drracket/keybindings.scrbl @@ -159,6 +159,13 @@ on how to bind keys to menu items on a selective basis. @keybinding["F5"]{Run} ] +@section{Documentation} +@itemize[ + @keybinding["f1"]{Search in the documentation for the words near the insertion point} + @keybinding["f2"]{Reveal the blue box for the identifier at the insertion point (requires + online check syntax to be enabled, or normal check syntax to have been + run).} +] @section{Interactions} diff --git a/collects/scribblings/scribble/core.scrbl b/collects/scribblings/scribble/core.scrbl index 07a5fcf142..1642ad22d5 100644 --- a/collects/scribblings/scribble/core.scrbl +++ b/collects/scribblings/scribble/core.scrbl @@ -290,18 +290,18 @@ HTML display when the mouse hovers over the text. The @techlink{collect pass}, @techlink{resolve pass}, and @techlink{render pass} processing steps all produce information that is specific to a rendering mode. Concretely, the operations are all -represented as methods on a @racket[render%] object. +represented as methods on a @racket[render<%>] object. -The result of the @method[render% collect] method is a +The result of the @method[render<%> collect] method is a @racket[collect-info] instance. This result is provided back as an -argument to the @method[render% resolve] method, which produces a +argument to the @method[render<%> resolve] method, which produces a @racket[resolve-info] value that encapsulates the results from both iterations. The @racket[resolve-info] value is provided back to the -@method[render% resolve] method for final rendering. +@method[render<%> resolve] method for final rendering. -Optionally, before the @method[render% resolve] method is called, +Optionally, before the @method[render<%> resolve] method is called, serialized information from other documents can be folded into the -@racket[collect-info] instance via the @method[render% +@racket[collect-info] instance via the @method[render<%> deserialize-info] method. Other methods provide serialized information out of the collected and resolved records. diff --git a/collects/scribblings/scribble/renderer.scrbl b/collects/scribblings/scribble/renderer.scrbl index c4c9dd2bfd..4e3c631c8d 100644 --- a/collects/scribblings/scribble/renderer.scrbl +++ b/collects/scribblings/scribble/renderer.scrbl @@ -114,51 +114,7 @@ the methods of the renderer. Documents built with higher layers, such as @racketmodname[scribble/manual], generally do not call the render object's methods directly. -@defclass[render% object% ()]{ - -Represents a renderer. - -@defconstructor[([dest-dir path-string?] - [refer-to-existing-files any/c #f] - [root-path (or/c path-string? #f) #f] - [prefix-file (or/c path-string? #f) #f] - [style-file (or/c path-string? #f) #f] - [style-extra-files (listof path-string?) null] - [extra-files (listof path-string?) null] - [helper-file-prefix (or/c string? #f) #f])]{ - -Creates a renderer whose output will go to @racket[dest-dir]. For -example, @racket[dest-dir] could name the directory containing the -output Latex file, the HTML file for a single-file output, or the -output sub-directory for multi-file HTML output. - -If @racket[refer-to-existing-files] is true, then when a document -refers to external files, such as an image or a style file, then the -file is referenced from its source location instead of copied to the -document destination. - -If @racket[root-path] is not @racket[#f], it is normally the same as -@racket[dest-dir] or a parent of @racket[dest-dir]. It causes -cross-reference information to record destination files relative to -@racket[root-path]; when cross-reference information is serialized, it -can be deserialized via @method[render% deserialize-info] with a -different root path (indicating that the destination files have -moved). - -The @racket[prefix-file], @racket[style-file], and -@racket[style-extra-files] arguments set files that control output -styles in a formal-specific way; see @secref["config-style"] for more -information. - -The @racket[extra-files] argument names files to be copied to the -output location, such as image files or extra configuration files. - -The @racket[helper-file-prefix] argument specifies a string that is -added as a prefix to the name of each support file that is generated -or copied to the destination---not including files specified in -@racket[extra-files], but including @racket[prefix-file], -@racket[style-file], and @racket[style-extra-files].} - +@definterface[render<%> ()]{ @defmethod[(traverse [srcs (listof part?)] [dests (listof path-string?)]) @@ -166,7 +122,7 @@ or copied to the destination---not including files specified in Performs the @techlink{traverse pass}, producing a hash table that contains the replacements for and @racket[traverse-block]s and -@racket[traverse-elements]s. See @method[render% render] for +@racket[traverse-elements]s. See @method[render<%> render] for information on the @racket[dests] argument.} @defmethod[(collect [srcs (listof part?)] @@ -174,18 +130,18 @@ information on the @racket[dests] argument.} [fp (and/c hash? immutable?)]) collect-info?]{ -Performs the @techlink{collect pass}. See @method[render% render] for +Performs the @techlink{collect pass}. See @method[render<%> render] for information on the @racket[dests] argument. The @racket[fp] argument -is a result from the @method[render% traverse] method.} +is a result from the @method[render<%> traverse] method.} @defmethod[(resolve [srcs (listof part?)] [dests (listof path-string?)] [ci collect-info?]) resolve-info?]{ -Performs the @techlink{resolve pass}. See @method[render% render] for +Performs the @techlink{resolve pass}. See @method[render<%> render] for information on the @racket[dests] argument. The @racket[ci] argument -is a result from the @method[render% collect] method.} +is a result from the @method[render<%> collect] method.} @defmethod[(render [srcs (listof part?)] [dests (listof path-string?)] @@ -193,7 +149,7 @@ is a result from the @method[render% collect] method.} void?]{ Produces the final output. The @racket[ri] argument is a result from -the @method[render% render] method. +the @method[render<%> render] method. The @racket[dests] provide names of files for Latex or single-file HTML output, or names of sub-directories for multi-file HTML output. @@ -248,15 +204,54 @@ then no tag in the set is included in the list of undefined tags.} } +@defclass[render% object% (render<%>)]{ + +Represents a renderer. + +@defconstructor[([dest-dir path-string?] + [refer-to-existing-files any/c #f] + [root-path (or/c path-string? #f) #f] + [prefix-file (or/c path-string? #f) #f] + [style-file (or/c path-string? #f) #f] + [style-extra-files (listof path-string?) null] + [extra-files (listof path-string?) null])]{ + +Creates a renderer whose output will go to @racket[dest-dir]. For +example, @racket[dest-dir] could name the directory containing the +output Latex file, the HTML file for a single-file output, or the +output sub-directory for multi-file HTML output. + +If @racket[refer-to-existing-files] is true, then when a document +refers to external files, such as an image or a style file, then the +file is referenced from its source location instead of copied to the +document destination. + +If @racket[root-path] is not @racket[#f], it is normally the same as +@racket[dest-dir] or a parent of @racket[dest-dir]. It causes +cross-reference information to record destination files relative to +@racket[root-path]; when cross-reference information is serialized, it +can be deserialized via @method[render<%> deserialize-info] with a +different root path (indicating that the destination files have +moved). + +The @racket[prefix-file], @racket[style-file], and +@racket[style-extra-files] arguments set files that control output +styles in a formal-specific way; see @secref["config-style"] for more +information. + +The @racket[extra-files] argument names files to be copied to the +output location, such as image files or extra configuration files.} +} + @; ---------------------------------------- @section{Text Renderer} @defmodule/local[scribble/text-render]{ -@defmixin[render-mixin (render%) ()]{ +@defmixin[render-mixin (render<%>) ()]{ -Specializes a @racket[render%] class for generating plain text.}} +Specializes a @racket[render<%>] class for generating plain text.}} @; ---------------------------------------- @@ -264,9 +259,9 @@ Specializes a @racket[render%] class for generating plain text.}} @defmodule/local[scribble/html-render]{ -@defmixin[render-mixin (render%) ()]{ +@defmixin[render-mixin (render<%>) ()]{ -Specializes a @racket[render%] class for generating HTML output. +Specializes a @racket[render<%>] class for generating HTML output. @defmethod[(set-external-tag-path [url string?]) void?]{ @@ -284,7 +279,7 @@ directory.} } -@defmixin[render-multi-mixin (render%) ()]{ +@defmixin[render-multi-mixin (render<%>) ()]{ Further specializes a rendering class produced by @racket[render-mixin] for generating multiple HTML @@ -298,9 +293,9 @@ files.} @defmodule/local[scribble/latex-render]{ -@defmixin[render-mixin (render%) ()]{ +@defmixin[render-mixin (render<%>) ()]{ -Specializes a @racket[render%] class for generating Latex input.}} +Specializes a @racket[render<%>] class for generating Latex input.}} @; ---------------------------------------- @@ -308,7 +303,63 @@ Specializes a @racket[render%] class for generating Latex input.}} @defmodule/local[scribble/pdf-render]{ -@defmixin[render-mixin (render%) ()]{ +@defmixin[render-mixin (render<%>) ()]{ -Specializes a @racket[render%] class for generating PDF output via +Specializes a @racket[render<%>] class for generating PDF output via Latex, building on @|latex:render-mixin| from @racketmodname[scribble/latex-render].}} + +@; ---------------------------------------- + +@section{Contract (Blue boxes) Renderer} + +@defmodule/local[scribble/contract-render]{ + +@defmixin[override-render-mixin-multi (render<%>) ()]{ + +Overrides the @method[render<%> render] method of +given renderer to record the content of the +blue boxes (generated by @racket[defproc], @racket[defform], etc) +that appear in the document. + +@defmethod[#:mode override + (render [srcs (listof part?)] + [dests (listof path?)] + [ri render-info?]) + void?]{ +In addition to doing whatever the @racket[super] method +does, also save the content of the blue boxes (rendered +via a @racketmodname[scribble/text-render] renderer). + +It saves this information in three pieces in a file +inside the @racket[dests] directories called +@filepath{contract-blueboxes.rktd}. The first piece is +a single line containing a (decimal, ASCII) number. That number +is the number of bytes that the second piece of information +occupies in the file. The second piece of information +is a @racket[hash] that maps @racket[tag?] values to +a list of offsets and line numbers that follow the hash table. +For example, if the @racket[hash] maps +@racket['(def ((lib "x/main.rkt") abcdef))] to +@racket['((10 . 3))], then that means that the documentation +for the @racket[abcdef] export from the @racket[x] collection +starts 10 bytes after the end of the hash table and continues for +@racket[3] lines. Multiple elements in the list mean that that +@racket[tag?] has multiple blue boxes and each shows where one +of the boxes appears in the file. +}} + +@defmixin[override-render-mixin-single (render<%>) ()]{ + +Just like @racket[override-render-mixin-multi], except +it saves the resulting files in a different place. + +@defmethod[#:mode override + (render [srcs (listof part?)] + [dests (listof path?)] + [ri render-info?]) + void?]{ + Just like @method[override-render-mixin-multi render], except + that it saves the file @filepath{contract-blueboxes.rktd} in + the same directory where each @racket[dests] element resides. +}} +} \ No newline at end of file diff --git a/collects/scribblings/scribble/struct-hierarchy.rkt b/collects/scribblings/scribble/struct-hierarchy.rkt index b542a33749..1c951369f0 100644 --- a/collects/scribblings/scribble/struct-hierarchy.rkt +++ b/collects/scribblings/scribble/struct-hierarchy.rkt @@ -124,9 +124,9 @@ image-element-scale) #f)) - (define multi-arg-element-name (class-name "multi-arg-\nelement")) - (define multi-arg-element-tag (field-spec #f "tag")) - (define multi-arg-element-box (class-box multi-arg-element-name (list multi-arg-element-tag) #f)) + (define multiarg-element-name (class-name "multiarg-\nelement")) + (define multiarg-element-tag (field-spec #f "tag")) + (define multiarg-element-box (class-box multiarg-element-name (list multiarg-element-tag) #f)) (define target-element-name (class-name "target-\nelement")) (define target-tag (field-spec #f "tag")) @@ -192,7 +192,7 @@ (blank 0 50) (inset (ht-append 20 collect-element-box - multi-arg-element-box + multiarg-element-box (refocus target-element-hierarchy target-element-box) link-element-box image-element-box @@ -203,7 +203,7 @@ index-element-box image-element-box target-element-box - multi-arg-element-box + multiarg-element-box link-element-box ))) diff --git a/collects/scribblings/scribble/xref.scrbl b/collects/scribblings/scribble/xref.scrbl index 4561997297..e5ce9e2dd1 100644 --- a/collects/scribblings/scribble/xref.scrbl +++ b/collects/scribblings/scribble/xref.scrbl @@ -20,13 +20,13 @@ by @racket[load-xref], @racket[#f] otherwise.} @defproc[(load-xref [sources (listof (-> any/c))] - [#:render% using-render% (subclass?/c render%) + [#:render% using-render% (implementation?/c render<%>) (render-mixin render%)] [#:root root-path (or/c path-string? false/c) #f]) xref?]{ Creates a cross-reference record given a list of functions that each -produce a serialized information obtained from @xmethod[render% +produce a serialized information obtained from @xmethod[render<%> serialize-info]. If a @racket[sources] element produces @racket[#f], its result is ignored. @@ -101,7 +101,7 @@ is found in @racket[xref], the result is @racket[#f].} @defproc[(xref-tag->path+anchor [xref xref?] [tag tag?] [#:external-root-url root-url (or/c string? #f) #f] - [#:render% using-render% (subclass?/c render%) + [#:render% using-render% (implementation?/c render<%>) (render-mixin render%)]) (values (or/c false/c path?) (or/c false/c string?))]{ @@ -133,7 +133,7 @@ the binding and its original name.} @defproc[(xref-render [xref xref?] [doc part?] [dest (or/c path-string? false/c)] - [#:render% using-render% (subclass?/c render%) + [#:render% using-render% (implemenation?/c render<%>) (render-mixin render%)] [#:refer-to-existing-files? use-existing? any/c (not dest)]) (or/c void? any/c)]{ @@ -156,7 +156,7 @@ rendering (such as image files) are referenced from their existing locations, instead of copying to the directory of @racket[dest].} -@defproc[(xref-transfer-info [renderer (is-a?/c render%)] +@defproc[(xref-transfer-info [renderer (is-a?/c render<%>)] [ci collect-info?] [xref xref?]) void?]{ diff --git a/collects/setup/scribble.rkt b/collects/setup/scribble.rkt index f11ede3321..038dcc1022 100644 --- a/collects/setup/scribble.rkt +++ b/collects/setup/scribble.rkt @@ -22,7 +22,8 @@ scribble/private/run-pdflatex unstable/file (prefix-in html: scribble/html-render) - (prefix-in latex: scribble/latex-render)) + (prefix-in latex: scribble/latex-render) + (prefix-in contract: scribble/contract-render)) (provide setup-scribblings verbose @@ -399,9 +400,14 @@ [main? (doc-under-main? doc)] [ddir (doc-dest-dir doc)] [root? (or (memq 'main-doc-root flags) - (memq 'user-doc-root flags))]) - (new ((if multi? html:render-multi-mixin values) - (html:render-mixin render%)) + (memq 'user-doc-root flags))] + [contract-override-mixin + (if multi? + contract:override-render-mixin-multi + contract:override-render-mixin-single)]) + (new (contract-override-mixin + ((if multi? html:render-multi-mixin values) + (html:render-mixin render%))) [dest-dir (if multi? (let-values ([(base name dir?) (split-path ddir)]) base) ddir)] @@ -424,17 +430,19 @@ [search-box? #t])))) (define (pick-dest latex-dest doc) - (cond [latex-dest + (cond [(path? latex-dest) (let-values ([(base name dir?) (split-path (doc-src-file doc))]) (build-path latex-dest (path-replace-suffix name #".tex")))] - [(memq 'multi-page (doc-flags doc)) (doc-dest-dir doc)] - [else (build-path (doc-dest-dir doc) "index.html")])) + [(not latex-dest) + (cond + [(memq 'multi-page (doc-flags doc)) (doc-dest-dir doc)] + [else (build-path (doc-dest-dir doc) "index.html")])])) (define (sxref-path latex-dest doc file) - (cond [latex-dest + (cond [(path? latex-dest) (let-values ([(base name dir?) (split-path (doc-src-file doc))]) (build-path latex-dest (path-replace-suffix name (string-append "." file))))] - [else (build-path (doc-dest-dir doc) file)])) + [(not latex-dest) (build-path (doc-dest-dir doc) file)])) (define (can-build? only-dirs doc) (or (not only-dirs) @@ -526,9 +534,9 @@ [renderer-path (build-path (collection-path "scribble") "compiled" (path-add-suffix - (if latex-dest - "latex-render.rkt" - "html-render.rkt") + (cond + [(path? latex-dest) "latex-render.rkt"] + [(not latex-dest) "html-render.rkt"]) ".zo"))] [css-path (collection-file-path "scribble.css" "scribble")] [aux-time (max (file-or-directory-modify-seconds/stamp diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index 4948c1323f..c66b46f3f2 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -990,9 +990,13 @@ (set-doc:verbose) (with-handlers ([exn:fail? (lambda (exn) - (setup-printf #f "docs failure: ~a" (exn->string exn)))]) - (doc:setup-scribblings #f (and (not (null? (archives))) - (archive-implies-reindex))))) + (setup-printf #f "docs failure: ~a" (exn->string exn)) + (for ([x (in-list (continuation-mark-set->context (exn-continuation-marks exn)))]) + (setup-printf #f "~s" x)))]) + (define auto-start-doc? + (and (not (null? (archives))) + (archive-implies-reindex))) + (doc:setup-scribblings #f auto-start-doc?))) (define (doc-pdf-dest-step) (setup-printf #f "--- building PDF documentation (via pdflatex) ---") @@ -1166,7 +1170,7 @@ (when (file-exists? (collection-file-path "scribble.rkt" "setup")) (make-docs-step))) (when (doc-pdf-dest) (doc-pdf-dest-step)) - + (do-install-part 'general) (do-install-part 'post) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index a0635c0ed6..cc865f047c 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -228,12 +228,16 @@ please adhere to these guidelines: (cs-mode-menu-show-client-obligations "Client Contract Obligations") (cs-mode-menu-show-syntax "Syntactic Categories") + ;; the documentation blue boxes in the upper-right corner of the drracket window + (sc-read-more... "read more ...") + (sc-f2-to-un/lock "f2 to (un)lock") + ;; the online check syntax status messages (mouse over the bottom right of drracket's window to see the messages during online expansion's various phases) (online-expansion-running "Online expansion running") (online-expansion-only-raw-text-files-supported "Only pure text files supported") (online-expansion-abnormal-termination "Online expansion terminated abnormally") (online-expansion-finished-successfully "Online expansion finished successfully") - + (jump-to-error "Jump to Error") (online-expansion-is-disabled "Online expansion is disabled") ;; these next two show up in the bar along the bottom of the drracket window diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index e5785bb0f1..83873f5e75 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.3.0.18" +#define MZSCHEME_VERSION "5.3.0.19" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 18 +#define MZSCHEME_VERSION_W 19 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)