830 lines
31 KiB
Racket
830 lines
31 KiB
Racket
#lang racket/base
|
||
(require framework
|
||
racket/gui/base
|
||
racket/class
|
||
racket/math
|
||
racket/runtime-path
|
||
racket/serialize
|
||
data/interval-map
|
||
setup/dirs
|
||
images/icons/misc
|
||
"../rectangle-intersect.rkt"
|
||
string-constants
|
||
framework/private/logging-timer)
|
||
(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 "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)
|
||
(deserialize (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
|
||
begin-edit-sequence end-edit-sequence
|
||
invalidate-bitmap-cache)
|
||
|
||
(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 the-strs #f)
|
||
(define the-strs-id-start #f)
|
||
(define the-strs-id-end #f)
|
||
(define/public (get-current-strs) the-strs)
|
||
|
||
(define visit-docs-url void)
|
||
|
||
(define/public (get-show-docs?) (and the-strs (or locked? mouse-in-blue-box?)))
|
||
(define/public (toggle-syncheck-docs)
|
||
(begin-edit-sequence)
|
||
(invalidate-blue-box-region)
|
||
(cond
|
||
[locked?
|
||
(set! mouse-in-blue-box? #f)]
|
||
[else
|
||
(update-the-strs)])
|
||
(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?))
|
||
(invalidate-blue-box-region)
|
||
(end-edit-sequence))
|
||
(define/public (update-mouse-in-blue-box b)
|
||
(unless (equal? b mouse-in-blue-box?)
|
||
(begin-edit-sequence)
|
||
(invalidate-blue-box-region)
|
||
(set! mouse-in-blue-box? b)
|
||
(invalidate-blue-box-region)
|
||
(end-edit-sequence)))
|
||
(define/public (update-locked b)
|
||
(preferences:set 'drracket:syncheck:contracts-locked? b)
|
||
(unless (equal? b locked?)
|
||
(begin-edit-sequence)
|
||
(invalidate-blue-box-region)
|
||
(set! locked? b)
|
||
(invalidate-blue-box-region)
|
||
(end-edit-sequence)))
|
||
(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?))
|
||
(begin-edit-sequence)
|
||
(invalidate-blue-box-region)
|
||
(set! mouse-in-lock-icon? lk?)
|
||
(set! mouse-in-read-more? rm?)
|
||
(invalidate-blue-box-region)
|
||
(end-edit-sequence)))
|
||
|
||
(define/private (invalidate-blue-box-region)
|
||
(define c (get-canvas))
|
||
(when c (send c refresh))
|
||
;; the code below is what I'd like to do here,
|
||
;; but this doesn't redraw the margin (the part
|
||
;; of the editor-canvas that is always outside
|
||
;; of th editor) and it doesn't seem possible to
|
||
;; trigger a redraw of that part without also
|
||
;; triggering a redraw of the entire editor
|
||
;; so we just do that instead (above)
|
||
|
||
#;
|
||
(begin
|
||
(define-values (br bt _1 _2) (get-box-upper-right-and-lock-coordinates))
|
||
(when (and bt br)
|
||
(cond
|
||
[(get-show-docs?)
|
||
(define-values (box-width box-height label-overlap?)
|
||
(get-blue-box-size (get-dc) (get-style-list) the-strs))
|
||
(define x (- br box-width shadow-size))
|
||
(invalidate-bitmap-cache (max x 0)
|
||
(max bt 0)
|
||
(+ box-width shadow-size)
|
||
(+ box-height shadow-size))]
|
||
[the-strs
|
||
(define size (+ corner-radius shadow-size))
|
||
(invalidate-bitmap-cache (max 0 (- br size)) (max 0 bt) size size)]))))
|
||
|
||
(define bx (box 0))
|
||
(define by (box 0))
|
||
(define bw (box 0))
|
||
(define bh (box 0))
|
||
|
||
(define docs-im #f)
|
||
(define/public (syncheck:reset-docs-im)
|
||
(set! docs-im #f))
|
||
(define (get/start-docs-im)
|
||
(cond
|
||
[docs-im docs-im]
|
||
[else
|
||
(set! docs-im (make-interval-map))
|
||
docs-im]))
|
||
(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! (get/start-docs-im) start (+ end 1) rng))
|
||
|
||
(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
|
||
[(and (bmp-bluebox-x . <= . bmp-view-x)
|
||
(bmp-bluebox-y . >= . bmp-view-y))
|
||
(values br bt bmp-view-x bmp-view-y)]
|
||
[(bmp-bluebox-y . >= . bmp-view-y)
|
||
(values br bt bmp-bluebox-x bmp-view-y)]
|
||
[(bmp-bluebox-x . <= . bmp-view-x)
|
||
(values br bt bmp-view-x bmp-bluebox-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-the-strs/maybe-invalidate void void)
|
||
(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 timer (new logging-timer%
|
||
[notify-callback
|
||
(λ ()
|
||
(set! timer-running? #f)
|
||
(update-the-strs))]))
|
||
(define timer-running? #f)
|
||
(define/augment (after-set-position)
|
||
(inner (void) after-set-position)
|
||
(when (or locked?
|
||
mouse-in-blue-box?
|
||
(not the-strs))
|
||
(unless timer-running?
|
||
(set! timer-running? #t)
|
||
(send timer start 300 #t))))
|
||
|
||
(define/public (syncheck:update-blue-boxes)
|
||
(update-the-strs))
|
||
|
||
(define/private (update-the-strs)
|
||
(update-the-strs/maybe-invalidate
|
||
(λ ()
|
||
(begin-edit-sequence)
|
||
(invalidate-blue-box-region))
|
||
(λ ()
|
||
(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?))
|
||
(invalidate-blue-box-region)
|
||
(end-edit-sequence))))
|
||
|
||
;; update-the-strs/maybe-invalidate : (-> void) (-> void) -> boolean
|
||
;; returns #t if something changed (and thus invalidation should happen)
|
||
(define/private (update-the-strs/maybe-invalidate before after)
|
||
(define sp (get-start-position))
|
||
(when (= sp (get-end-position))
|
||
(define tag+rng (interval-map-ref (get/start-docs-im) sp #f))
|
||
(when tag+rng
|
||
(define ir-start (list-ref tag+rng 0))
|
||
(define ir-end (list-ref tag+rng 1))
|
||
(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
|
||
(before)
|
||
(set! the-strs new-strs)
|
||
(set! the-strs-id-start ir-start)
|
||
(set! the-strs-id-end ir-end)
|
||
(set! visit-docs-url new-visit-docs-url)
|
||
(after)))))
|
||
|
||
(define/augment (on-insert where len)
|
||
(when docs-im
|
||
(clear-im-range where len)
|
||
(interval-map-expand! docs-im where (+ where len))
|
||
(possibly-clobber-strs where len #f)
|
||
(when the-strs-id-start
|
||
(when (<= where the-strs-id-start)
|
||
(set! the-strs-id-start (+ the-strs-id-start len))
|
||
(set! the-strs-id-end (+ the-strs-id-end len)))))
|
||
(inner (void) on-insert where len))
|
||
|
||
(define/augment (on-delete where len)
|
||
(when docs-im
|
||
(clear-im-range where len)
|
||
(interval-map-contract! docs-im where (+ where len))
|
||
(possibly-clobber-strs where len #t)
|
||
(when the-strs-id-start
|
||
(when (<= where the-strs-id-start)
|
||
(set! the-strs-id-start (- the-strs-id-start len))
|
||
(set! the-strs-id-end (- the-strs-id-end len)))))
|
||
(inner (void) on-delete where len))
|
||
|
||
(define/private (possibly-clobber-strs where len delete?)
|
||
(when (or (not the-strs-id-start)
|
||
(not the-strs-id-end)
|
||
(and (<= the-strs-id-start where)
|
||
(< where the-strs-id-end))
|
||
(and delete? (<= the-strs-id-start (+ where len) the-strs-id-end)))
|
||
(when the-strs
|
||
(begin-edit-sequence)
|
||
(invalidate-blue-box-region)
|
||
(set! the-strs #f)
|
||
(set! the-strs-id-start #f)
|
||
(set! the-strs-id-end #f)
|
||
(invalidate-blue-box-region)
|
||
(end-edit-sequence))))
|
||
|
||
(define/private (clear-im-range where len)
|
||
(when docs-im
|
||
(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)]
|
||
[(and (get-show-docs?) (get-dc))
|
||
(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 blue-box-margin blue-box-margin)
|
||
(+ read-more-w blue-box-margin blue-box-margin))
|
||
(+ 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))))
|