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