(module display-break-stuff mzscheme

  (require mred mzlib/class "marks.ss")

  (provide display-break-stuff)

  (define f
    (new frame%
      [label (format "Breakpoints Inspector")]
      [width 400] [height 500]))
  (define sel (new choice% [label "Breakpoint#"] [choices '()] [parent f]
                   [callback (lambda (c e) (show-sel))] [stretchable-width #t]))
  (define ec  (new editor-canvas% [parent f]))
  (define t   (new text%))
  (send ec set-editor t)

  (define selections '())
  (define (add-sel num mset bkind retvals)
    (set! selections (cons (list num mset bkind retvals) selections))
    (let ([num (number->string num)])
      (send sel append num)
      (send sel set-string-selection num)
      (show-sel)))

  (define (show-sel)
    (let* ([num (string->number (send sel get-string-selection))]
           [bpt (assq num selections)])
      (send* t (lock #f) (erase))
      (if (not bpt)
        (send* t (insert (format "Breakpoint #~a not found!\n" num)))
        (let-values ([(mset bkind retvals) (apply values (cdr bpt))])
          (send* t
            (insert (format "Breakpoint #~a:\n" num))
            (insert (format "  break-kind: ~v\n" bkind))
            (insert "marks:\n"))
          (if mset
            (for-each
             (lambda (mark)
               (let* ([em (expose-mark mark)]
                      [source (car em)]
                      [label (cadr em)]
                      [binding-set (caddr em)])
                 (send* t
                   (insert (format "  label: ~v\n" label))
                   ;; we really want one of those nice collapsible
                   ;; syntax-viewer thingies here:
                   (insert (format "  source : ~v\n"
                                   (syntax-object->datum source)))
                   ;; here too, though this isn't a syntax object.
                   (insert (format "  bindings: ~v\n" binding-set)))))
             (extract-mark-list mset))
            (send t insert "  nothing!\n"))
          (send t insert "returned-value-list:\n")
          (if retvals
            (for-each (lambda (v) (send t insert (format "  ~v\n" v)))
                      retvals)
            (send t insert "  nothing!\n"))))
      (send* t (lock #t))))

  ;; display-break-stuff : show the information associated with a breakpoint.
  ;; Useful for people building steppers for new languages
  (define (display-break-stuff break-number mark-set break-kind
                               returned-value-list)
    (add-sel break-number mark-set break-kind returned-value-list)
    (send f show #t))

  )
