889 lines
39 KiB
Racket
889 lines
39 KiB
Racket
(module hierlist-unit racket/base
|
|
(require racket/class
|
|
racket/unit
|
|
mred/mred-sig
|
|
mrlib/include-bitmap
|
|
"hierlist-sig.rkt")
|
|
|
|
;; Previously was a rename-in from mzlib/list, but
|
|
;; now it's imported from racket/base
|
|
(define sort* sort)
|
|
|
|
(define turn-up (include-bitmap "../../icons/turn-up.png" 'png/mask))
|
|
(define turn-down (include-bitmap "../../icons/turn-down.png" 'png/mask))
|
|
(define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png/mask))
|
|
(define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png/mask))
|
|
|
|
(provide hierlist@)
|
|
(define-unit hierlist@
|
|
(import mred^)
|
|
(export hierlist^)
|
|
(init-depend mred^)
|
|
|
|
(define-local-member-name
|
|
;; In hierarchical-list%
|
|
ensure-not-selected)
|
|
|
|
(define transparent (make-object brush% "WHITE" 'transparent))
|
|
(define transparent-pen (make-object pen% "WHITE" 1 'transparent))
|
|
(define black-xor-pen (make-object pen% (get-highlight-background-color) 1 'solid))
|
|
(define red (make-object brush% "RED" 'solid))
|
|
(define blue (make-object brush% "BLUE" 'solid))
|
|
(define black-xor (make-object brush% (get-highlight-background-color) 'solid))
|
|
(define arrow-cursor (make-object cursor% 'arrow))
|
|
|
|
(define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap)
|
|
(values turn-up turn-down turn-up-click turn-down-click))
|
|
|
|
;; Hack for implementing auto-wrapping items:
|
|
(define arrow-size 0)
|
|
|
|
(define orig-size (max (send up-click-bitmap get-width) (send up-click-bitmap get-height)))
|
|
|
|
;; Private arrow snip class:
|
|
(define arrow-snip-class (make-object snip-class%))
|
|
(send arrow-snip-class set-classname "hier-arrow")
|
|
(define arrow-snip%
|
|
(class snip%
|
|
(init callback)
|
|
(inherit get-admin set-flags get-flags set-count set-snipclass get-style)
|
|
(rename-super [super-get-extent get-extent])
|
|
(define size-calculated? #f)
|
|
(define size orig-size)
|
|
(define width-fraction 1/2)
|
|
(define on? #f)
|
|
(define click-callback callback)
|
|
(define clicked? #f)
|
|
(private*
|
|
[set-sizes
|
|
(lambda (dc)
|
|
(let* ([s (get-style)]
|
|
[h (send s get-text-height dc)]
|
|
[d (send s get-text-descent dc)]
|
|
[a (send s get-text-space dc)])
|
|
(set! size (max orig-size (- h d a)))
|
|
(set! size-calculated? #t)
|
|
(set! arrow-size size)))]
|
|
[get-width (lambda () size)]
|
|
[get-height (lambda () size)]
|
|
[update
|
|
(lambda ()
|
|
(send (get-admin) needs-update this 0 0 (get-width) (get-height)))])
|
|
(override*
|
|
[get-extent (lambda (dc x y w h descent space lspace rspace)
|
|
(super-get-extent dc x y w h descent space lspace rspace)
|
|
(unless size-calculated? (set-sizes dc))
|
|
(when w (set-box! w (get-width)))
|
|
(when h (set-box! h (get-height)))
|
|
(when descent (set-box! descent 0))
|
|
(when space (set-box! space 0)))]
|
|
[partial-offset (lambda (dc x y len)
|
|
(unless size-calculated? (set-sizes dc))
|
|
(if (zero? len)
|
|
0
|
|
(get-width)))]
|
|
[draw (lambda (dc x y left top right bottom dx dy draw-caret)
|
|
(unless size-calculated? (set-sizes dc))
|
|
(let* ([bitmap (if clicked?
|
|
(if on? down-click-bitmap up-click-bitmap)
|
|
(if on? down-bitmap up-bitmap))]
|
|
[bw (send bitmap get-width)]
|
|
[bh (send bitmap get-height)])
|
|
(send dc draw-bitmap-section bitmap
|
|
(+ x (max 0 (- (/ size 2) (/ bw 2))))
|
|
(+ y (max 0 (- (/ size 2) (/ bh 2))))
|
|
0 0 (min bw (+ size 2)) (min bh (+ size 2))
|
|
'solid
|
|
(send the-color-database find-color "black")
|
|
(send bitmap get-loaded-mask))))]
|
|
[size-cache-invalid (lambda () (set! size-calculated? #f))]
|
|
[on-event
|
|
(lambda (dc x y mediax mediay event)
|
|
(let ([in-range?
|
|
(and (<= 0 (- (send event get-x) x) (get-width))
|
|
(<= 0 (- (send event get-y) y) (get-height)))])
|
|
(cond
|
|
[(send event button-down?)
|
|
(when in-range?
|
|
(unless clicked?
|
|
(set! clicked? #t)
|
|
(update)))]
|
|
[(send event button-up?)
|
|
(when clicked?
|
|
(set! clicked? #f)
|
|
(update))
|
|
(when in-range?
|
|
(on (not on?))
|
|
(click-callback this))]
|
|
[(send event dragging?)
|
|
(unless (or (and clicked? in-range?)
|
|
(and (not clicked?) (not in-range?)))
|
|
(set! clicked? (not clicked?))
|
|
(update))]
|
|
[else (when clicked?
|
|
(set! clicked? #f)
|
|
(update))])))]
|
|
[copy (lambda () (make-object arrow-snip% click-callback))])
|
|
(public*
|
|
[on (case-lambda
|
|
[(v) (set! on? v) (update)]
|
|
[() on?])])
|
|
|
|
(super-make-object)
|
|
(set-snipclass arrow-snip-class)
|
|
(set-count 1)
|
|
(set-flags (cons 'handles-events (get-flags)))))
|
|
|
|
;; Hack to get whitespace matching width of arrow: derive a new
|
|
;; class that overrides the `draw' method to do nothing.
|
|
(define whitespace-snip%
|
|
(class arrow-snip%
|
|
(override* [draw (lambda (dc x y left top right bottom dx dy draw-caret) (void))])
|
|
(super-make-object void)))
|
|
|
|
;; Keymap to map clicks and double-clicks
|
|
(define item-keymap (make-object keymap%))
|
|
|
|
(send item-keymap add-function "mouse-select"
|
|
(lambda (edit event) (when (send event button-down?)
|
|
(send edit click-select #t)
|
|
;; To handle hypertext clicks:
|
|
(send edit on-default-event event))))
|
|
(send item-keymap add-function "mouse-double-select"
|
|
(lambda (edit event) (when (send event button-down?)
|
|
(send edit double-select))))
|
|
|
|
(send item-keymap map-function "leftbutton" "mouse-select")
|
|
(send item-keymap map-function "leftbuttondouble" "mouse-double-select")
|
|
|
|
(define hierarchical-list-item<%>
|
|
(interface ()
|
|
get-editor
|
|
is-selected?
|
|
select
|
|
user-data
|
|
get-allow-selection?
|
|
set-allow-selection
|
|
get-clickable-snip
|
|
get-parent))
|
|
|
|
(define hierarchical-list-item%
|
|
(class* object% (hierarchical-list-item<%>)
|
|
(init snp)
|
|
(define snip snp)
|
|
(define data #f)
|
|
(define allow-selection #t)
|
|
(public*
|
|
[get-allow-selection? (lambda () allow-selection)]
|
|
[set-allow-selection (lambda (_a) (set! allow-selection _a))]
|
|
|
|
[get-clickable-snip (lambda () snip)]
|
|
[get-editor (lambda () (send snip get-item-buffer))]
|
|
|
|
;; the `get-editor' method is overridden
|
|
[is-selected? (lambda () (send (get-editor) is-selected?))]
|
|
|
|
[select (lambda (on?) (send snip select on?))]
|
|
[click-select (lambda (on?) (send snip click-select on?))]
|
|
[scroll-to (lambda () (let* ([admin (send snip get-admin)]
|
|
[dc (and admin (send admin get-dc))]
|
|
[h-box (box 0.0)])
|
|
(when dc
|
|
(send snip get-extent dc 0 0 #f h-box #f #f #f #f)
|
|
(send admin
|
|
scroll-to
|
|
snip
|
|
0 0 0 (unbox h-box) #t))))]
|
|
[user-data (case-lambda [() data][(x) (set! data x)])]
|
|
[get-parent (lambda ()
|
|
(let ([parent-of-snip (send snip get-parent)])
|
|
(and parent-of-snip
|
|
(let ([parent-snip (send parent-of-snip get-parent-snip)])
|
|
(and parent-snip
|
|
(send parent-snip get-item))))))])
|
|
(super-make-object)))
|
|
|
|
(define hierarchical-list-compound-item<%>
|
|
(interface (hierarchical-list-item<%>)
|
|
new-item
|
|
new-list
|
|
delete-item
|
|
get-items
|
|
open
|
|
close
|
|
toggle-open/closed
|
|
is-open?
|
|
get-arrow-snip))
|
|
|
|
(define hierarchical-list-compound-item%
|
|
(class* hierarchical-list-item% (hierarchical-list-compound-item<%>)
|
|
(init snp)
|
|
(define snip snp)
|
|
(override*
|
|
[get-editor (lambda () (send snip get-title-buffer))])
|
|
(public*
|
|
[get-arrow-snip (lambda () (send snip get-arrow-snip))]
|
|
[open
|
|
(lambda ()
|
|
(send snip open))]
|
|
[close
|
|
(lambda ()
|
|
(send snip close))]
|
|
[toggle-open/closed
|
|
(lambda ()
|
|
(send snip toggle-open/closed))]
|
|
[is-open?
|
|
(lambda ()
|
|
(send snip is-open?))]
|
|
[new-item
|
|
(lambda x
|
|
(begin0
|
|
(send (send snip get-content-buffer) new-item . x)
|
|
(send snip not-empty-anymore)))]
|
|
[set-no-sublists (lambda x (send (send snip get-content-buffer) set-no-sublists . x))]
|
|
[new-list
|
|
(lambda x
|
|
(begin0
|
|
(send (send snip get-content-buffer) new-list . x)
|
|
(send snip not-empty-anymore)))]
|
|
[delete-item (lambda (i) (begin0
|
|
(send (send snip get-content-buffer) delete-item i)
|
|
(send snip check-empty-now)))]
|
|
[get-items (lambda () (send (send snip get-content-buffer) get-items))])
|
|
(super-make-object snip)))
|
|
|
|
;; Buffer for a single list item
|
|
(define hierarchical-item-text%
|
|
(class text%
|
|
(init tp tp-select itm snp dpth)
|
|
(inherit hide-caret
|
|
last-position set-position set-keymap
|
|
invalidate-bitmap-cache set-max-width
|
|
get-view-size)
|
|
(rename-super [super-auto-wrap auto-wrap]
|
|
[super-on-default-event on-default-event])
|
|
|
|
(define top tp)
|
|
(define top-select tp-select)
|
|
(define item itm)
|
|
(define snip snp)
|
|
(define depth dpth)
|
|
(define selected? #f)
|
|
(public*
|
|
[is-selected? (lambda () selected?)]
|
|
[show-select (lambda (on?)
|
|
(set! selected? on?)
|
|
(invalidate-bitmap-cache))])
|
|
(override*
|
|
[auto-wrap (case-lambda
|
|
[() (super-auto-wrap)]
|
|
[(on?) (super-auto-wrap on?)
|
|
(when on?
|
|
(let ([wbox (box 0)])
|
|
(send (send top get-editor) get-view-size wbox (box 0))
|
|
;; These icky constants should be eliminated
|
|
(let ([w (- (unbox wbox) 8 (* depth arrow-size))])
|
|
(set-max-width (if (positive? w)
|
|
w
|
|
'none)))))])]
|
|
[refresh (lambda (x y width height draw-caret background)
|
|
(super refresh x y width height
|
|
(if (and selected?
|
|
(or (not (send top show-focus))
|
|
(send top has-focus?)))
|
|
(cons 0 1)
|
|
draw-caret)
|
|
background))]
|
|
[on-paint
|
|
(lambda (pre? dc left top_ right bottom dx dy caret)
|
|
(when (and pre? selected?)
|
|
(let ([b (send dc get-brush)]
|
|
[p (send dc get-pen)]
|
|
[filled? (or (not (send top show-focus))
|
|
(send top has-focus?))])
|
|
(unless filled?
|
|
;; To draw the right outline, we need the display area
|
|
(set! left 0)
|
|
(set! top_ 0)
|
|
(let ([wbox (box 0)]
|
|
[hbox (box 0)])
|
|
(get-view-size wbox hbox)
|
|
(set! right (unbox wbox))
|
|
(set! bottom (unbox hbox))))
|
|
(send dc set-brush (if filled? black-xor transparent))
|
|
(send dc set-pen (if filled? transparent-pen black-xor-pen))
|
|
(send dc draw-rectangle (+ dx left) (+ dy top_) (- right left) (- bottom top_))
|
|
(unless (or filled? ((- right left) . < . 2) ((- bottom top_) . < . 2))
|
|
(send dc draw-rectangle (+ dx left 1) (+ dy top_ 1) (- right left 2) (- bottom top_ 2)))
|
|
(send dc set-pen p)
|
|
(send dc set-brush b))))])
|
|
(private*
|
|
;; need to use top-select anyway, because it might want to react to
|
|
;; all clicks
|
|
[do-select (lambda (on? clicked?)
|
|
(top-select (if on? item #f) snip clicked?
|
|
(not (eq? (not selected?) (not on?)))))])
|
|
(public*
|
|
[select (lambda (on?) (do-select on? #f))]
|
|
[click-select (lambda (on?) (do-select on? #t))]
|
|
[double-select (lambda () (send top on-double-select item))]
|
|
[select-prev (lambda () (send top select-prev))])
|
|
(override*
|
|
[on-default-char (lambda (x) (void))]
|
|
[can-do-edit-operation? (lambda (x [r? #t])
|
|
(and (super can-do-edit-operation? x r?)
|
|
(send top can-do-edit-operation? x r?)))]
|
|
[do-edit-operation (lambda (x [r? #t] [time 0]) (send top do-edit-operation x r? time))])
|
|
(super-make-object)
|
|
(hide-caret #t)
|
|
(set-keymap item-keymap)))
|
|
|
|
;; Buffer for a compound list item (and the top-level list)
|
|
(define (make-hierarchical-list-text% super%)
|
|
(class super%
|
|
(init tp tp-select dpth parent-snp)
|
|
(inherit hide-caret erase
|
|
last-position insert delete line-start-position line-end-position
|
|
begin-edit-sequence end-edit-sequence get-style-list)
|
|
(define top tp)
|
|
(define top-select tp-select)
|
|
(define depth dpth)
|
|
(define parent-snip parent-snp)
|
|
(define children null)
|
|
(define new-children null)
|
|
(define no-sublists? #f)
|
|
(define transparent? #f)
|
|
(private*
|
|
[append-children! (lambda ()
|
|
(unless (null? new-children)
|
|
(set! children (append children (reverse new-children)))
|
|
(set! new-children null)))]
|
|
[make-whitespace (lambda () (make-object whitespace-snip%))]
|
|
[insert-item
|
|
(lambda (mixin snip% whitespace?)
|
|
(let ([s (make-object snip% this top top-select (add1 depth) mixin)])
|
|
(send s use-style-background transparent?)
|
|
(begin-edit-sequence)
|
|
(unless (and (null? children)
|
|
(null? new-children))
|
|
(insert #\newline (last-position)))
|
|
(when whitespace?
|
|
(insert (make-whitespace) (last-position)))
|
|
(insert s (last-position))
|
|
(end-edit-sequence)
|
|
(set! new-children (cons s new-children))
|
|
(send s get-item)))])
|
|
(public*
|
|
[set-transparent (λ (t?) (set! transparent? (and t? #t)))]
|
|
[get-parent-snip (lambda () parent-snip)]
|
|
[deselect-all
|
|
(lambda ()
|
|
(append-children!)
|
|
(for-each (lambda (x) (send x deselect-all)) children))]
|
|
[new-item
|
|
(case-lambda
|
|
[() (new-item (lambda (x) x))]
|
|
[(mixin)
|
|
(insert-item mixin hierarchical-item-snip% (not no-sublists?))])]
|
|
[new-list
|
|
(case-lambda
|
|
[() (new-list (lambda (x) x))]
|
|
[(mixin)
|
|
(when no-sublists?
|
|
(error 'new-list "this list has been designated with `set-no-sublists' as having no sublists"))
|
|
(insert-item mixin hierarchical-list-snip% #f)])]
|
|
[set-no-sublists
|
|
(lambda (no?)
|
|
(append-children!)
|
|
(unless (null? children)
|
|
(error 'set-no-sublists "cannot change sublist mode because the list is non-empty"))
|
|
(set! no-sublists? (and no? #t)))]
|
|
[get-items (lambda ()
|
|
(append-children!)
|
|
(map (lambda (x) (send x get-item)) children))]
|
|
[delete-item
|
|
(lambda (i)
|
|
(append-children!)
|
|
(let loop ([pos 0][l children][others null])
|
|
(cond
|
|
[(null? l) (error 'hierarchical-list-compound-item::delete-item "item not found: ~a" i)]
|
|
[(eq? (send (car l) get-item) i)
|
|
(send top ensure-not-selected i)
|
|
(send (car l) deselect-all)
|
|
(set! children (append (reverse others) (cdr l)))
|
|
(let ([s (line-start-position pos)]
|
|
[e (line-end-position pos)])
|
|
(delete (if (zero? s) s (sub1 s)) (if (zero? s) (add1 e) e)))]
|
|
[else (loop (add1 pos) (cdr l) (cons (car l) others))])))]
|
|
[sort (lambda (less-than? [recur? #t])
|
|
(append-children!)
|
|
(let ([l (sort* children
|
|
(lambda (a b)
|
|
(less-than? (send a get-item)
|
|
(send b get-item))))])
|
|
(begin-edit-sequence)
|
|
(when recur?
|
|
(for-each (lambda (child)
|
|
(when (is-a? child hierarchical-list-snip%)
|
|
(let ([ed (send child get-content-buffer)])
|
|
(when (is-a? ed hierarchical-list-text%)
|
|
(send ed sort less-than?)))))
|
|
children))
|
|
(erase)
|
|
(let ([to-scroll-to #f])
|
|
(for-each
|
|
(lambda (s)
|
|
(unless to-scroll-to
|
|
(when (and (is-a? (send s get-item) hierarchical-list-item<%>)
|
|
(send (send s get-item) is-selected?))
|
|
(set! to-scroll-to s)))
|
|
(unless (or no-sublists?
|
|
(is-a? s hierarchical-list-snip%))
|
|
(insert (make-whitespace)))
|
|
(insert s)
|
|
(insert #\newline))
|
|
l)
|
|
(unless (null? l)
|
|
(delete)) ; delete last #\newline
|
|
(set! children l)
|
|
(when to-scroll-to
|
|
(send (send to-scroll-to get-item) scroll-to)))
|
|
(end-edit-sequence)))]
|
|
[reflow-items
|
|
(lambda ()
|
|
(append-children!)
|
|
(for-each
|
|
(lambda (c)
|
|
(send c reflow-item))
|
|
children))])
|
|
(override*
|
|
[on-default-char (lambda (x) (void))]
|
|
[on-default-event (lambda (x) (void))]
|
|
[can-do-edit-operation? (lambda (x [r? #t])
|
|
(and (super can-do-edit-operation? x r?)
|
|
(send top can-do-edit-operation? x r?)))]
|
|
[do-edit-operation (lambda (x [r? #t] [time 0]) (send top do-edit-operation x r? time))])
|
|
(super-make-object)
|
|
(hide-caret #t)))
|
|
|
|
(define hierarchical-list-text% (make-hierarchical-list-text% text%))
|
|
|
|
;; Snip for a single list item
|
|
(define hierarchical-item-snip%
|
|
(class editor-snip%
|
|
(init prnt top top-select depth mixin)
|
|
(define parent prnt)
|
|
(public*
|
|
[get-parent (lambda () parent)]
|
|
[get-item-text% (lambda () hierarchical-item-text%)]
|
|
[select (lambda (on?) (send item-buffer select on?))]
|
|
[click-select (lambda (on?) (send item-buffer click-select on?))]
|
|
[deselect-all (lambda () (select #f))]
|
|
[show-select (lambda (on?) (send item-buffer show-select on?))]
|
|
[get-item-buffer (lambda () item-buffer)]
|
|
[get-item (lambda () item)]
|
|
[reflow-item (lambda ()
|
|
(when (send item-buffer auto-wrap)
|
|
(send item-buffer auto-wrap #t)))])
|
|
|
|
(define item (make-object (mixin hierarchical-list-item%) this))
|
|
(define item-buffer (make-object (get-item-text%) top top-select item this depth))
|
|
(super-make-object item-buffer #f 0 0 0 0 0 0 0 0)))
|
|
|
|
;; Snip for a compound list item
|
|
(define hierarchical-list-snip%
|
|
(class editor-snip%
|
|
(init prnt tp top-select depth mixin [title #f][content #f])
|
|
(define parent prnt)
|
|
(define top tp)
|
|
(public*
|
|
[get-parent (lambda () parent)]
|
|
[get-main-text% (lambda () (class text%
|
|
(init-rest args)
|
|
(override*
|
|
[on-default-char (lambda (x) (void))]
|
|
[on-default-event (lambda (x) (void))]
|
|
[can-do-edit-operation? (lambda (x [r? #t])
|
|
(and (super can-do-edit-operation? x r?)
|
|
(send top can-do-edit-operation? x r?)))]
|
|
[do-edit-operation (lambda (x [r? #t] [time 0]) (send top do-edit-operation x r? time))])
|
|
(apply super-make-object args)))]
|
|
[get-title-text% (lambda () hierarchical-item-text%)]
|
|
[get-content-text% (lambda () hierarchical-list-text%)]
|
|
[get-arrow-snip% (lambda () arrow-snip%)]
|
|
[select (lambda (on?) (send title-buffer select on?))]
|
|
[click-select (lambda (on?) (send title-buffer click-select on?))]
|
|
[deselect-all (lambda ()
|
|
(select #f)
|
|
(send content-buffer deselect-all))]
|
|
[show-select (lambda (on?) (send title-buffer show-select on?))]
|
|
[not-empty-anymore (lambda ()
|
|
(when was-empty?
|
|
(set! was-empty? #f)
|
|
(set! was-non-empty? #t)
|
|
(send main-buffer begin-edit-sequence)
|
|
(send main-buffer insert #\newline 2)
|
|
(send main-buffer insert whitespace 3)
|
|
(send main-buffer insert content-snip 4)
|
|
(send main-buffer end-edit-sequence)))]
|
|
[check-empty-now (lambda ()
|
|
(when (and was-non-empty?
|
|
(zero? (send content-buffer last-position)))
|
|
(set! was-empty? #t)
|
|
(set! was-non-empty? #f)
|
|
(send main-buffer delete 2 5)))]
|
|
[open (lambda () (handle-open #t))]
|
|
[close (lambda () (handle-close #t))]
|
|
[is-open? (lambda () open?)]
|
|
[toggle-open/closed
|
|
(lambda ()
|
|
(if open?
|
|
(handle-close #t)
|
|
(handle-open #t)))]
|
|
[on-arrow (lambda (a)
|
|
(if (send a on)
|
|
(handle-open #f)
|
|
(handle-close #f)))]
|
|
[get-title-buffer (lambda () title-buffer)]
|
|
[get-content-buffer (lambda () content-buffer)]
|
|
[get-item (lambda () item)]
|
|
[reflow-item (lambda ()
|
|
(when (send title-buffer auto-wrap)
|
|
(send title-buffer auto-wrap #t))
|
|
(send (send content-snip get-editor) reflow-items))])
|
|
(define open? #f)
|
|
(private*
|
|
[handle-open
|
|
(lambda (update-arrow?)
|
|
(unless open?
|
|
(set! open? #t)
|
|
(when update-arrow? (send arrow on #t))
|
|
(send main-buffer begin-edit-sequence)
|
|
(send top on-item-opened (get-item))
|
|
(if (zero? (send content-buffer last-position))
|
|
(set! was-empty? #t)
|
|
(begin
|
|
(set! was-non-empty? #t)
|
|
(send main-buffer insert #\newline 2)
|
|
(send main-buffer insert whitespace 3)
|
|
(send main-buffer insert content-snip 4)))
|
|
(send main-buffer scroll-to-position 0
|
|
#f
|
|
(send main-buffer last-position)
|
|
'start)
|
|
(send main-buffer end-edit-sequence)))]
|
|
[handle-close
|
|
(lambda (update-arrow?)
|
|
(when open?
|
|
(set! open? #f)
|
|
(when update-arrow? (send arrow on #f))
|
|
(set! was-empty? #f)
|
|
(set! was-non-empty? #f)
|
|
(send main-buffer begin-edit-sequence)
|
|
(send content-buffer deselect-all)
|
|
(send main-buffer delete 2 5)
|
|
(send top on-item-closed (get-item))
|
|
(send main-buffer end-edit-sequence)))])
|
|
(define was-empty? #f)
|
|
(define was-non-empty? #f)
|
|
(define item (make-object (mixin hierarchical-list-compound-item%) this))
|
|
(define main-buffer (make-object (get-main-text%)))
|
|
(define title-buffer (make-object (get-title-text%) top top-select item this depth))
|
|
(define content-buffer (make-object (get-content-text%) top top-select depth this))
|
|
(define title-snip (make-object editor-snip% title-buffer #f 0 0 0 0 0 0 0 0))
|
|
(define content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0))
|
|
(define arrow (make-object (get-arrow-snip%) (lambda (a) (on-arrow a))))
|
|
(define whitespace (make-object whitespace-snip%))
|
|
(override*
|
|
[use-style-background
|
|
(λ (x)
|
|
(super use-style-background x)
|
|
(send title-snip use-style-background x)
|
|
(send content-snip use-style-background x)
|
|
(send content-buffer set-transparent x))])
|
|
(public*
|
|
[get-arrow-snip (lambda () arrow)])
|
|
(inherit style-background-used?)
|
|
(super-make-object main-buffer #f 0 0 0 0 0 0 0 0)
|
|
(send main-buffer hide-caret #t)
|
|
(send main-buffer insert arrow)
|
|
(when title (send title-buffer insert title))
|
|
(when content (send content-buffer insert content))
|
|
(send main-buffer insert title-snip)
|
|
(send main-buffer change-style (make-object style-delta% 'change-alignment 'top) 0 2)))
|
|
|
|
(define list-keymap (make-object keymap%))
|
|
|
|
(send list-keymap add-function "select-in"
|
|
(lambda (list event) (send list select-in)))
|
|
(send list-keymap add-function "select-out"
|
|
(lambda (list event) (send list select-out)))
|
|
(send list-keymap add-function "select-prev"
|
|
(lambda (list event) (send list select-prev)))
|
|
(send list-keymap add-function "select-next"
|
|
(lambda (list event) (send list select-next)))
|
|
(send list-keymap add-function "select-first"
|
|
(lambda (list event) (send list select-first)))
|
|
(send list-keymap add-function "select-last"
|
|
(lambda (list event) (send list select-last)))
|
|
(send list-keymap add-function "page-up"
|
|
(lambda (list event) (send list page-up)))
|
|
(send list-keymap add-function "page-down"
|
|
(lambda (list event) (send list page-down)))
|
|
|
|
(send list-keymap map-function "right" "select-in")
|
|
(send list-keymap map-function "left" "select-out")
|
|
(send list-keymap map-function "up" "select-prev")
|
|
(send list-keymap map-function "down" "select-next")
|
|
(send list-keymap map-function "home" "select-first")
|
|
(send list-keymap map-function "end" "select-last")
|
|
(send list-keymap map-function "pageup" "page-up")
|
|
(send list-keymap map-function "pagedown" "page-down")
|
|
(send list-keymap map-function "a:up" "page-up")
|
|
(send list-keymap map-function "a:down" "page-down")
|
|
(send list-keymap map-function "m:up" "page-up")
|
|
(send list-keymap map-function "m:down" "page-down")
|
|
(send list-keymap map-function "d:up" "select-first")
|
|
(send list-keymap map-function "d:down" "select-last")
|
|
(send list-keymap map-function "esc;v" "page-up")
|
|
(send list-keymap map-function "c:v" "page-down")
|
|
(send list-keymap map-function "esc;>" "select-last")
|
|
(send list-keymap map-function "esc;<" "select-first")
|
|
|
|
(send list-keymap add-function "toggle-open/closed"
|
|
(lambda (list event) (send list toggle-open/closed)))
|
|
(send list-keymap map-function "return" "toggle-open/closed")
|
|
|
|
(define hierarchical-list%
|
|
(class editor-canvas%
|
|
(init parent [style '(no-hscroll)])
|
|
(inherit min-width min-height allow-tab-exit refresh)
|
|
(rename-super [super-on-char on-char]
|
|
[super-on-focus on-focus])
|
|
(public*
|
|
[selectable
|
|
(case-lambda
|
|
[() selectable?]
|
|
[(on?) (set! selectable? on?)])]
|
|
[get-selected (lambda () selected-item)]
|
|
[on-item-opened (lambda (i) (void))]
|
|
[on-item-closed (lambda (i) (void))]
|
|
[on-double-select (lambda (i) (void))]
|
|
[on-select (lambda (i) (void))]
|
|
[on-click (lambda (i) (void))]
|
|
[new-item (lambda x (send top-buffer new-item . x))]
|
|
[set-no-sublists (lambda x (send top-buffer set-no-sublists . x))]
|
|
[new-list (lambda x (send top-buffer new-list . x))]
|
|
[delete-item (lambda (i) (send top-buffer delete-item i))]
|
|
[sort (lambda (less-than? [recur? #t]) (send top-buffer sort less-than? recur?))]
|
|
[get-items (lambda () (send top-buffer get-items))]
|
|
[toggle-open/closed
|
|
(lambda ()
|
|
(cond
|
|
[(and selected (is-a? selected hierarchical-list-snip%))
|
|
(send selected toggle-open/closed)]
|
|
[else
|
|
(void)]))]
|
|
[select-out (lambda ()
|
|
(when selected
|
|
(let* ([parent-snip (send (send selected get-parent) get-parent-snip)])
|
|
(cond
|
|
[parent-snip
|
|
(let ([parent (send parent-snip get-item)])
|
|
(when (send parent get-allow-selection?)
|
|
(send parent click-select #t)
|
|
(send parent scroll-to)))]
|
|
[else
|
|
(void)]))))]
|
|
[select-in (lambda ()
|
|
(cond
|
|
[(and selected (is-a? selected hierarchical-list-snip%))
|
|
(let ([edit-sequence-text (send selected get-editor)])
|
|
(send edit-sequence-text begin-edit-sequence)
|
|
(send selected open)
|
|
(let ([items (send selected-item get-items)])
|
|
(unless (null? items)
|
|
(send (car items) click-select #t)
|
|
(send (car items) scroll-to)))
|
|
(send edit-sequence-text end-edit-sequence))]
|
|
[else (void)]))]
|
|
[select-next (lambda () (move +1))]
|
|
[select-prev (lambda () (move -1))]
|
|
[select-first (lambda () (let ([l (get-items)])
|
|
(unless (null? l)
|
|
(send (car l) click-select #t)
|
|
(send (car l) scroll-to))))]
|
|
[select-last (lambda () (let loop ([l (get-items)])
|
|
(cond
|
|
[(null? l) (void)]
|
|
[(null? (cdr l))
|
|
(send (car l) click-select #t)
|
|
(send (car l) scroll-to)]
|
|
[else (loop (cdr l))])))]
|
|
[select (lambda (i)
|
|
(cond
|
|
[i
|
|
(send i select #t)
|
|
(send i scroll-to)]
|
|
[(allow-deselect)
|
|
(when selected
|
|
(send selected show-select #f)
|
|
(set! selected #f)
|
|
(set! selected-item #f))]
|
|
[else
|
|
(error 'hierarchical-list%::select
|
|
"can only pass #f when allow-deselect has been called with #t")]))]
|
|
[click-select (lambda (i)
|
|
(send i click-select #t)
|
|
(send i scroll-to))]
|
|
[page-up (lambda () (page 'up))]
|
|
[page-down (lambda () (page 'down))]
|
|
[show-focus
|
|
(case-lambda
|
|
[() show-focus?]
|
|
[(on?) (set! show-focus? on?)])]
|
|
[can-do-edit-operation? (lambda (x [r? #t]) #f)]
|
|
[do-edit-operation (lambda (x [r? #t] [time 0]) (void))])
|
|
(public* ;; ---- local to this module! ----
|
|
[ensure-not-selected (lambda (i)
|
|
(when (eq? i selected)
|
|
(set! selected #f))
|
|
(when (eq? i selected-item)
|
|
(set! selected-item #f)))])
|
|
(override*
|
|
[on-char
|
|
(lambda (e)
|
|
(unless (send list-keymap handle-key-event this e)
|
|
(super-on-char e)))]
|
|
[on-size
|
|
(lambda (w h)
|
|
(send top-buffer begin-edit-sequence)
|
|
(send top-buffer reflow-items)
|
|
(send top-buffer end-edit-sequence))]
|
|
[on-focus
|
|
(lambda (on?)
|
|
(when (and selected show-focus?)
|
|
(send selected show-select #t))
|
|
(super-on-focus on?))])
|
|
(private*
|
|
[move (lambda (dir)
|
|
(define (find i l)
|
|
(let loop ([l l][pos 0])
|
|
(if (null? l)
|
|
#f
|
|
(if (eq? (car l) i)
|
|
pos
|
|
(loop (cdr l) (add1 pos))))))
|
|
(define (find-next-selectable-item i vec)
|
|
(let loop ([pos (+ i dir)])
|
|
(cond
|
|
[(= pos -1)
|
|
i]
|
|
[(= pos (vector-length vec))
|
|
i]
|
|
[(send (vector-ref vec pos) get-allow-selection?)
|
|
pos]
|
|
[else (loop (+ pos dir))])))
|
|
;; Scrolling works differently depending on whether selections
|
|
;; are involved:
|
|
(if selectable?
|
|
(let* ([l (if selected
|
|
(send (send selected get-parent) get-items)
|
|
(get-items))]
|
|
[vec (list->vector l)]
|
|
[pos (let ([found (find selected-item l)])
|
|
(if (and selected-item found)
|
|
(find-next-selectable-item found vec)
|
|
(if (negative? dir)
|
|
(sub1 (length l))
|
|
0)))])
|
|
(when (< -1 pos (length l))
|
|
(let ([i (vector-ref vec pos)])
|
|
(when (send i get-allow-selection?)
|
|
(send i click-select #t)
|
|
(send i scroll-to)))))
|
|
(let ([y-box (box 0.0)]
|
|
[x-box (box 0.0)]
|
|
[w-box (box 0.0)]
|
|
[h-box (box 0.0)])
|
|
(send (send top-buffer get-admin) get-view x-box y-box w-box h-box)
|
|
(let ([y (if (negative? dir)
|
|
(- (unbox y-box) 2)
|
|
(+ (unbox y-box) (unbox h-box) 1))])
|
|
(send (send top-buffer get-admin) scroll-to
|
|
(unbox x-box) y
|
|
(unbox w-box) 1)))))]
|
|
[page (lambda (dir)
|
|
;; Scrolling works differently depending on whether selections
|
|
;; are involved:
|
|
(if selectable?
|
|
(let ([items (get-items)])
|
|
(unless (null? items)
|
|
(let ([sbox (box 0)]
|
|
[ebox (box 0)])
|
|
(send top-buffer get-visible-line-range sbox ebox)
|
|
(let* ([len (max 1 (sub1 (- (unbox ebox) (unbox sbox))))]
|
|
[l (if (eq? dir 'up)
|
|
(max 0 (- (unbox sbox) len))
|
|
(min (sub1 (length items)) (+ (unbox ebox) len)))]
|
|
[i (list-ref items l)])
|
|
(send i click-select #t)
|
|
(send i scroll-to)))))
|
|
(send top-buffer move-position dir #f 'page)))])
|
|
(define selectable? #t)
|
|
(define show-focus? #f)
|
|
(define on-select-always? #t)
|
|
(define on-click-always? #f)
|
|
(define allow-deselect? #f)
|
|
(public*
|
|
[on-select-always
|
|
(case-lambda
|
|
[() on-select-always?]
|
|
[(v) (set! on-select-always? (and v #t))])]
|
|
[on-click-always
|
|
(case-lambda
|
|
[() on-click-always?]
|
|
[(v) (set! on-click-always? (and v #t))])]
|
|
[allow-deselect
|
|
(case-lambda
|
|
[() allow-deselect?]
|
|
[(v) (set! allow-deselect? (and v #t))])])
|
|
(private*
|
|
[do-select (lambda (item s clicked? selected?)
|
|
(when (and item clicked? on-click-always?)
|
|
(on-click item))
|
|
(cond
|
|
[(not selected?)
|
|
;; this wasn't really a selection, only useful if
|
|
;; on-click-always? made us do an on-click above
|
|
(void)]
|
|
[(and selectable?
|
|
item
|
|
(send item get-allow-selection?))
|
|
(unless (eq? item selected-item)
|
|
(when selected (send selected show-select #f))
|
|
(set! selected (if item s #f))
|
|
(set! selected-item item)
|
|
(when selected (send selected show-select #t))
|
|
(when (or clicked? on-select-always?)
|
|
(on-select item)))]
|
|
[(and item clicked?)
|
|
(unless on-click-always? ; already called above
|
|
(on-click item))]
|
|
[allow-deselect?
|
|
(when selected-item
|
|
(send selected show-select #f)
|
|
(set! selected #f)
|
|
(set! selected-item #f))
|
|
(when (or clicked? on-select-always?)
|
|
(on-select #f))]))])
|
|
(define top-buffer (make-object hierarchical-list-text% this (lambda (i s c? s?) (do-select i s c? s?)) 0 #f))
|
|
(define selected #f)
|
|
(define selected-item #f)
|
|
(send top-buffer set-transparent (member 'transparent style))
|
|
(super-make-object parent top-buffer style)
|
|
(allow-tab-exit #t)
|
|
(send top-buffer set-cursor arrow-cursor)
|
|
(min-width 150)
|
|
(min-height 200)))))
|