(module widget mzscheme
(require "pretty-snip.ss"
"color.ss"
"hrule-snip.ss"
"partition.ss"
(lib "class.ss")
(lib "mred.ss" "mred"))
(provide syntax-widget%)
(define syntax-widget%
(class* object% ()
(init parent)
(define -parent parent)
(define -panel (new vertical-panel% (parent -parent)))
(define -control-panel
(new horizontal-pane% (parent -panel) (stretchable-height #f)))
(define -choice (new choice% (label "identifer=?") (parent -control-panel)
(choices (map car identifier=-choices))
(callback (lambda _ (on-update-identifier=?-choice)))))
(new button%
(label "De-select all")
(parent -control-panel)
(callback
(lambda _ (for-each (lambda (c) (send c show-syntax #f))
(map cdr a:snip=>colorer)))))
(define -text (new text%))
(define -ecanvas (new editor-canvas% (parent -panel) (editor -text)))
(define a:snip=>colorer null)
(define -primary-partition (new-bound-partition))
(define -secondary-partition #f)
(define/public (add-text text)
(send -text insert text))
(define/public (add-syntax stx)
(add-syntax2 stx #f))
(define/public (add-syntax2 stx selected-stx)
(let* ([new-snip (new snip-typesetter% (controller this))]
[new-syntax-pp (new syntax-pp% (main-stx stx) (typesetter new-snip))]
[new-colorer (new syntax-snip-colorer%
(syntax-pp new-syntax-pp)
(snip new-snip)
(controller this))])
(set! a:snip=>colorer
(cons (cons new-snip new-colorer) a:snip=>colorer))
(let ([current-position (send -text last-position)])
(send* -text
(lock #f)
(insert new-snip)
(insert "\n")
(insert (new hrule-snip%))
(insert "\n")
(lock #t)
(scroll-to-position current-position)))
(when selected-stx (send new-colorer show-syntax selected-stx))))
(define/public (separate)
(send* -text
(lock #f)
(insert "<<Separate>>\n")
(insert (new hrule-snip%))
(insert "\n")
(lock #t)))
(define/public (on-select-syntax snip stx)
(send (cdr (assq snip a:snip=>colorer)) show-syntax stx))
(define/public (on-update-identifier=?-choice)
(set! -secondary-partition
(new partition% (relation (get-identifier=?))))
(for-each (lambda (colorer) (send colorer refresh))
(map cdr a:snip=>colorer)))
(define/public (get-primary-partition)
-primary-partition)
(define/public (get-secondary-partition)
-secondary-partition)
(define (get-identifier=?)
(cond [(assoc (send -choice get-string-selection)
identifier=-choices)
=> cdr]
[else #f]))
(set! -secondary-partition
(new partition% (relation (get-identifier=?))))
(send -text hide-caret #t)
(super-new)))
)