(module widget mzscheme
  (require "pretty-snip.ss"
           "color.ss"
           "hrule-snip.ss"
           "partition.ss"
           (lib "class.ss")
           (lib "mred.ss" "mred"))
  (provide syntax-widget%)

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