gui/snip-gui.ss
(module snip-gui mzscheme

  (require (lib "contract.ss")
           (lib "class.ss")
           (lib "mred.ss" "mred")
           (lib "mrpict.ss" "texpict")
           (lib "etc.ss")
           "snip-mixins.ss"
           "interfaces.ss")

  (provide/contract
   [choice-snip% (class/c snip%)])

  (define choice-snip%
    (class (custom-snip-mixin snip%)
      (super-new)

      ;; choices : (NonEmptyListof String)
      ;; The list of choices presented to the user.
      ;; choice : NaturalNumber s.t. (< choice (length choices))
      ;; The initial/current choice index.
      (init-field choices [choice 0])

      (inherit get-admin get-location)
      (public get-choice-index get-choice-text get-choices choose)
      (override paint extent on-event)
      (private show-popup-menu get-popup-menu)

      ;; get-choice-index : -> Nat
      ;; Gets the index of the current choice from the list.
      (define (get-choice-index)
        choice)

      ;; get-choice-string : -> String
      ;; Gets the text of the current choice from the list.
      (define (get-choice-text)
        (list-ref choices choice))

      ;; get-choices : -> (NonEmptyListof String)
      ;; Gets the text of available choices, in order.
      (define (get-choices)
        choices)

      ;; choose : Nat -> Void
      ;; Given a valid index, changes the current choice.
      (define (choose index)
        (set! choice index)
        (send (get-admin) resized #t))

      ;; on-event : DC Real Real Real Real MouseEvent -> Void
      ;; Responds to a mouse event.
      (define (on-event dc x y ed-x ed-y event)
        (if (and (send event button-changed? 'left)
                 (send event button-down? 'left))
            (show-popup-menu)))

      ;; show-popup-menu : -> Void
      ;; Displays a popup menu of each choice.
      (define (show-popup-menu)
        (let*-values ([(x y w h) (get-location #f)])
          (send (send (send (get-admin) get-editor) get-admin)
                popup-menu
                (get-popup-menu)
                x (+ y h))))

      ;; get-popup-menu : -> PopupMenu
      ;; Produces a popup menu of choices.
      (define (get-popup-menu)
        (let* ([menu (new popup-menu%)]
               [choices (get-choices)])
          (for-each
           (lambda (index choice)
             (new menu-item%
                  [label choice]
                  [parent menu]
                  [callback (lambda (i e) (choose index))]))
           (build-list (length choices) identity)
           choices)
          menu))

      ;; paint : Easel -> Void
      ;; Draws the snip to the given easel.
      (define (paint easel)
        (send easel paint-pict 0 0 (text (get-choice-text))))

      ;; extent : DC Real real -> Real Real Real Real Real Real
      ;; Computes the size of the snip's visual representation.
      (define (extent dc x y)
        (let*-values ([(width height descent ascent)
                       (send dc get-text-extent (get-choice-text))])
          (values width height descent ascent 0 0)))))

  )