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

Add the contents of the "blue boxes" in the docs to the upper-right

Browse Source 
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
This commit is contained in:
Robby Findler 2012-08-11 22:56:38 -05:00
parent 5d81b80736
commit 0c6734f782
17 changed files with 1242 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/drracket/private/rectangle-intersect.rkt
View File

@ -2,11 +2,53 @@
(provide rectangles-intersect?) (provide rectangles-intersect?)
(define (rectangles-intersect? l1 t1 r1 b1 l2 t2 r2 b2) (define (rectangles-intersect? l1 t1 r1 b1 l2 t2 r2 b2)
(or (point-in-rectangle? l1 t1 l2 t2 r2 b2) (or (rectangles-intersect-one-way? l1 t1 r1 b1 l2 t2 r2 b2)
(point-in-rectangle? r1 t1 l2 t2 r2 b2) (rectangles-intersect-one-way? l2 t2 r2 b2 l1 t1 r1 b1)))
(point-in-rectangle? l1 b1 l2 t2 r2 b2)
(point-in-rectangle? r1 b1 l2 t2 r2 b2)))
(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) (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))

771
collects/drracket/private/syncheck/contract-gui.rkt Normal file
View File

@ -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))))

59
collects/drracket/private/syncheck/gui.rkt
View File

@ -47,7 +47,8 @@ If the namespace does not, they are colored the unbound color.
"colors.rkt" "colors.rkt"
"traversals.rkt" "traversals.rkt"
"annotate.rkt" "annotate.rkt"
"../tooltip.rkt") "../tooltip.rkt"
"contract-gui.rkt")
(provide tool@) (provide tool@)
(define orig-output-port (current-output-port)) (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% (define make-syncheck-text%
(λ (super%) (λ (super%)
(let* ([cursor-arrow (make-object cursor% 'arrow)]) (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 (inherit set-cursor get-admin invalidate-bitmap-cache set-position
get-pos/text get-pos/text-dc-location position-location get-pos/text get-pos/text-dc-location position-location
get-canvas last-position dc-location-to-editor-location get-canvas last-position dc-location-to-editor-location
find-position begin-edit-sequence end-edit-sequence find-position begin-edit-sequence end-edit-sequence
highlight-range unhighlight-range 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-records : (U #f hash[text% => arrow-record])
;; arrow-record = interval-map[(listof arrow-entry)] ;; arrow-record = interval-map[(listof arrow-entry)]
@ -581,7 +583,21 @@ If the namespace does not, they are colored the unbound color.
(void)) (void))
(syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file))) (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 (syncheck:add-menu
text start-pos end-pos id text start-pos end-pos id
(λ (menu) (λ (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)) (label (gui-utils:format-literal-label "~a" the-label))
(callback (callback
(λ (x y) (λ (x y)
(let* ([url (path->url path)] (visit-docs-url)))))))
[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)))))))))
(define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?) (define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?)
(define (make-menu menu) (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 ;; 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 wrong canvas half the time - when the current admin isn't
;; the admin for the canvas the mouse is over. ;; 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) (define/public (syncheck:build-popup-menu pos text)
(and pos (and pos
@ -1576,7 +1581,8 @@ If the namespace does not, they are colored the unbound color.
;; reset any previous check syntax information ;; reset any previous check syntax information
(let ([tab (get-current-tab)]) (let ([tab (get-current-tab)])
(send tab syncheck:clear-error-message) (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 (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running)
(send defs-text syncheck:init-arrows) (send defs-text syncheck:init-arrows)
@ -1584,6 +1590,7 @@ If the namespace does not, they are colored the unbound color.
[i 0]) [i 0])
(cond (cond
[(null? val) [(null? val)
(send defs-text syncheck:update-blue-boxes)
(send defs-text syncheck:update-drawn-arrows) (send defs-text syncheck:update-drawn-arrows)
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck) (send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
(set-syncheck-running-mode #f)] (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)] (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) [`(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)] (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) [`(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 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) [`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
(define other-side-dead? #f) (define other-side-dead? #f)
(define (name-dup? name) (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:c;c:c" "check syntax")
(send keymap map-function "c:x;b" "jump to binding occurrence") (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;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<%>)) ;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>))
(define (find-syncheck-text 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) syncheck-add-to-preferences-panel)
(drracket:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t) (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-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-unit-frame unit-frame-mixin #f)
(drracket:get/extend:extend-tab tab-mixin) (drracket:get/extend:extend-tab tab-mixin)
(drracket:module-language-tools:add-online-expansion-handler (drracket:module-language-tools:add-online-expansion-handler
compile-comp.rkt online-comp.rkt
'go 'go
(λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window) (λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window)
replay-compile-comp-trace replay-compile-comp-trace
defs-text defs-text
val))))) val)))))
(define-runtime-path compile-comp.rkt "online-comp.rkt") (define-runtime-path online-comp.rkt "online-comp.rkt")

3
collects/drracket/private/syncheck/traversals.rkt
View File

@ -972,7 +972,7 @@
(when source-editor (when source-editor
(define info (get-index-entry-info binding-info)) (define info (get-index-entry-info binding-info))
(when 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 (send defs-text syncheck:add-background-color
source-editor start fin source-editor start fin
"palegreen") "palegreen")
@ -983,6 +983,7 @@
(syntax-e stx) (syntax-e stx)
(build-docs-label entry-desc) (build-docs-label entry-desc)
path path
definition-tag
tag)))))) tag))))))
(define (build-docs-label entry-desc) (define (build-docs-label entry-desc)

1
collects/drracket/private/syncheck/xref.rkt
View File

@ -35,6 +35,7 @@
(and index-entry (and index-entry
(list (entry-desc index-entry) (list (entry-desc index-entry)
path path
definition-tag
tag)))))))))) tag))))))))))
(thread (thread
(λ () (λ ()

31
collects/scribble/base-render.rkt
View File

@ -11,10 +11,37 @@
file/convertible file/convertible
"render-struct.rkt") "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% (define render%
(class object% (class* object% (render<%>)
(init-field dest-dir (init-field dest-dir
[refer-to-existing-files #f] [refer-to-existing-files #f]

182
collects/scribble/contract-render.rkt Normal file
View File

@ -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))

7
collects/scribble/text-render.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #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) scribble/text/wrap)
(provide render-mixin) (provide render-mixin)
@ -15,8 +16,8 @@
(newline) (newline)
(indent)) (indent))
(define (render-mixin %) (define render-mixin
(class % (mixin (render<%>) ()
(define/override (current-render-mode) (define/override (current-render-mode)
'(text)) '(text))

7
collects/scribblings/drracket/keybindings.scrbl
View File

@ -159,6 +159,13 @@ on how to bind keys to menu items on a selective basis.
@keybinding["F5"]{Run} @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} @section{Interactions}

12
collects/scribblings/scribble/core.scrbl
View File

@ -290,18 +290,18 @@ HTML display when the mouse hovers over the text.
The @techlink{collect pass}, @techlink{resolve pass}, and The @techlink{collect pass}, @techlink{resolve pass}, and
@techlink{render pass} processing steps all produce information that @techlink{render pass} processing steps all produce information that
is specific to a rendering mode. Concretely, the operations are all 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 @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 @racket[resolve-info] value that encapsulates the results from both
iterations. The @racket[resolve-info] value is provided back to the 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 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 deserialize-info] method. Other methods provide serialized information
out of the collected and resolved records. out of the collected and resolved records.

171
collects/scribblings/scribble/renderer.scrbl
View File

@ -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 as @racketmodname[scribble/manual], generally do not call the render
object's methods directly. object's methods directly.
@defclass[render% object% ()]{ @definterface[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]
[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].}
@defmethod[(traverse [srcs (listof part?)] @defmethod[(traverse [srcs (listof part?)]
[dests (listof path-string?)]) [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 Performs the @techlink{traverse pass}, producing a hash table that
contains the replacements for and @racket[traverse-block]s and 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.} information on the @racket[dests] argument.}
@defmethod[(collect [srcs (listof part?)] @defmethod[(collect [srcs (listof part?)]
@ -174,18 +130,18 @@ information on the @racket[dests] argument.}
[fp (and/c hash? immutable?)]) [fp (and/c hash? immutable?)])
collect-info?]{ 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 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?)] @defmethod[(resolve [srcs (listof part?)]
[dests (listof path-string?)] [dests (listof path-string?)]
[ci collect-info?]) [ci collect-info?])
resolve-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 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?)] @defmethod[(render [srcs (listof part?)]
[dests (listof path-string?)] [dests (listof path-string?)]
@ -193,7 +149,7 @@ is a result from the @method[render% collect] method.}
void?]{ void?]{
Produces the final output. The @racket[ri] argument is a result from 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 The @racket[dests] provide names of files for Latex or single-file
HTML output, or names of sub-directories for multi-file HTML output. 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} @section{Text Renderer}
@defmodule/local[scribble/text-render]{ @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]{ @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?]{ @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 Further specializes a rendering class produced by
@racket[render-mixin] for generating multiple HTML @racket[render-mixin] for generating multiple HTML
@ -298,9 +293,9 @@ files.}
@defmodule/local[scribble/latex-render]{ @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]{ @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].}} 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.
}}
}

10
collects/scribblings/scribble/struct-hierarchy.rkt
View File

@ -124,9 +124,9 @@
image-element-scale) image-element-scale)
#f)) #f))
(define multi-arg-element-name (class-name "multi-arg-\nelement")) (define multiarg-element-name (class-name "multiarg-\nelement"))
(define multi-arg-element-tag (field-spec #f "tag")) (define multiarg-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-box (class-box multiarg-element-name (list multiarg-element-tag) #f))
(define target-element-name (class-name "target-\nelement")) (define target-element-name (class-name "target-\nelement"))
(define target-tag (field-spec #f "tag")) (define target-tag (field-spec #f "tag"))
@ -192,7 +192,7 @@
(blank 0 50) (blank 0 50)
(inset (ht-append 20 (inset (ht-append 20
collect-element-box collect-element-box
multi-arg-element-box multiarg-element-box
(refocus target-element-hierarchy target-element-box) (refocus target-element-hierarchy target-element-box)
link-element-box link-element-box
image-element-box image-element-box
@ -203,7 +203,7 @@
index-element-box index-element-box
image-element-box image-element-box
target-element-box target-element-box
multi-arg-element-box multiarg-element-box
link-element-box link-element-box
))) )))

10
collects/scribblings/scribble/xref.scrbl
View File

@ -20,13 +20,13 @@ by @racket[load-xref], @racket[#f] otherwise.}
@defproc[(load-xref [sources (listof (-> any/c))] @defproc[(load-xref [sources (listof (-> any/c))]
[#:render% using-render% (subclass?/c render%) [#:render% using-render% (implementation?/c render<%>)
(render-mixin render%)] (render-mixin render%)]
[#:root root-path (or/c path-string? false/c) #f]) [#:root root-path (or/c path-string? false/c) #f])
xref?]{ xref?]{
Creates a cross-reference record given a list of functions that each 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], serialize-info]. If a @racket[sources] element produces @racket[#f],
its result is ignored. 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?] @defproc[(xref-tag->path+anchor [xref xref?]
[tag tag?] [tag tag?]
[#:external-root-url root-url (or/c string? #f) #f] [#: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%)]) (render-mixin render%)])
(values (or/c false/c path?) (values (or/c false/c path?)
(or/c false/c string?))]{ (or/c false/c string?))]{
@ -133,7 +133,7 @@ the binding and its original name.}
@defproc[(xref-render [xref xref?] @defproc[(xref-render [xref xref?]
[doc part?] [doc part?]
[dest (or/c path-string? false/c)] [dest (or/c path-string? false/c)]
[#:render% using-render% (subclass?/c render%) [#:render% using-render% (implemenation?/c render<%>)
(render-mixin render%)] (render-mixin render%)]
[#:refer-to-existing-files? use-existing? any/c (not dest)]) [#:refer-to-existing-files? use-existing? any/c (not dest)])
(or/c void? any/c)]{ (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].} 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?] [ci collect-info?]
[xref xref?]) [xref xref?])
void?]{ void?]{

32
collects/setup/scribble.rkt
View File

@ -22,7 +22,8 @@
scribble/private/run-pdflatex scribble/private/run-pdflatex
unstable/file unstable/file
(prefix-in html: scribble/html-render) (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 (provide setup-scribblings
verbose verbose
@ -399,9 +400,14 @@
[main? (doc-under-main? doc)] [main? (doc-under-main? doc)]
[ddir (doc-dest-dir doc)] [ddir (doc-dest-dir doc)]
[root? (or (memq 'main-doc-root flags) [root? (or (memq 'main-doc-root flags)
(memq 'user-doc-root flags))]) (memq 'user-doc-root flags))]
(new ((if multi? html:render-multi-mixin values) [contract-override-mixin
(html:render-mixin render%)) (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? [dest-dir (if multi?
(let-values ([(base name dir?) (split-path ddir)]) base) (let-values ([(base name dir?) (split-path ddir)]) base)
ddir)] ddir)]
@ -424,17 +430,19 @@
[search-box? #t])))) [search-box? #t]))))
(define (pick-dest latex-dest doc) (define (pick-dest latex-dest doc)
(cond [latex-dest (cond [(path? latex-dest)
(let-values ([(base name dir?) (split-path (doc-src-file doc))]) (let-values ([(base name dir?) (split-path (doc-src-file doc))])
(build-path latex-dest (path-replace-suffix name #".tex")))] (build-path latex-dest (path-replace-suffix name #".tex")))]
[(memq 'multi-page (doc-flags doc)) (doc-dest-dir doc)] [(not latex-dest)
[else (build-path (doc-dest-dir doc) "index.html")])) (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) (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))]) (let-values ([(base name dir?) (split-path (doc-src-file doc))])
(build-path latex-dest (path-replace-suffix name (string-append "." file))))] (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) (define (can-build? only-dirs doc)
(or (not only-dirs) (or (not only-dirs)
@ -526,9 +534,9 @@
[renderer-path (build-path (collection-path "scribble") [renderer-path (build-path (collection-path "scribble")
"compiled" "compiled"
(path-add-suffix (path-add-suffix
(if latex-dest (cond
"latex-render.rkt" [(path? latex-dest) "latex-render.rkt"]
"html-render.rkt") [(not latex-dest) "html-render.rkt"])
".zo"))] ".zo"))]
[css-path (collection-file-path "scribble.css" "scribble")] [css-path (collection-file-path "scribble.css" "scribble")]
[aux-time (max (file-or-directory-modify-seconds/stamp [aux-time (max (file-or-directory-modify-seconds/stamp

12
collects/setup/setup-unit.rkt
View File

@ -990,9 +990,13 @@
(set-doc:verbose) (set-doc:verbose)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(setup-printf #f "docs failure: ~a" (exn->string exn)))]) (setup-printf #f "docs failure: ~a" (exn->string exn))
(doc:setup-scribblings #f (and (not (null? (archives))) (for ([x (in-list (continuation-mark-set->context (exn-continuation-marks exn)))])
(archive-implies-reindex))))) (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) (define (doc-pdf-dest-step)
(setup-printf #f "--- building PDF documentation (via pdflatex) ---") (setup-printf #f "--- building PDF documentation (via pdflatex) ---")
@ -1166,7 +1170,7 @@
(when (file-exists? (collection-file-path "scribble.rkt" "setup")) (when (file-exists? (collection-file-path "scribble.rkt" "setup"))
(make-docs-step))) (make-docs-step)))
(when (doc-pdf-dest) (doc-pdf-dest-step)) (when (doc-pdf-dest) (doc-pdf-dest-step))
(do-install-part 'general) (do-install-part 'general)
(do-install-part 'post) (do-install-part 'post)

6
collects/string-constants/private/english-string-constants.rkt
View File

@ -228,12 +228,16 @@ please adhere to these guidelines:
(cs-mode-menu-show-client-obligations "Client Contract Obligations") (cs-mode-menu-show-client-obligations "Client Contract Obligations")
(cs-mode-menu-show-syntax "Syntactic Categories") (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) ;; 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-running "Online expansion running")
(online-expansion-only-raw-text-files-supported "Only pure text files supported") (online-expansion-only-raw-text-files-supported "Only pure text files supported")
(online-expansion-abnormal-termination "Online expansion terminated abnormally") (online-expansion-abnormal-termination "Online expansion terminated abnormally")
(online-expansion-finished-successfully "Online expansion finished successfully") (online-expansion-finished-successfully "Online expansion finished successfully")
(jump-to-error "Jump to Error") (jump-to-error "Jump to Error")
(online-expansion-is-disabled "Online expansion is disabled") (online-expansion-is-disabled "Online expansion is disabled")
;; these next two show up in the bar along the bottom of the drracket window ;; these next two show up in the bar along the bottom of the drracket window

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.3.0.18" #define MZSCHEME_VERSION "5.3.0.19"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 0 #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_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)