(module color mzscheme
  (require (lib "class.ss")
           (lib "mred.ss" "mred")
           "interfaces.ss"
           "pretty-snip.ss")
  (provide syntax-snip-colorer%)
  
  (define colors 
    (list "black" "darkred" "red"
          "green" "mediumforestgreen" "darkgreen" 
          "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
          "indigo" "purple" 
          "orange" "salmon" "darkgoldenrod" "olive"))
  
  (define (set-box/f! b v) (when (box? b) (set-box! b v)))

  ;; syntax-snip-colorer%
  (define syntax-snip-colorer%
    (class object%
      ;; snip : snip%
      (init-field snip)
      
      ;; syntax-pp : syntax-pp<%>
      (init-field syntax-pp)
      
      ;; controller : color-controller<%>
      (init-field controller)

      (init-field (primary-color-all-syntax? #t))
      
      (define range (send syntax-pp get-range))
      (define text (send snip get-editor))
      (define identifier-list (send syntax-pp get-identifier-list))
      (define color-partition (send controller get-primary-partition))
      (define selected-syntax #f)
      (define highlighted-syntaxes null)
      (define highlight-color "yellow")
      
      (define/public (get-snip) snip)
      (define/public (get-syntax-pp) syntax-pp)
      (define/public (get-selected-syntax) selected-syntax)
      
      (define/public (show-syntax stx)
        (set! selected-syntax stx)
        (refresh))
      
      (define/public (highlight-syntaxes stxs hi-color)
        (set! highlighted-syntaxes stxs)
        (when (string? hi-color) (set! highlight-color hi-color))
        (refresh))
      
      (define/private (restyle-range r style)
        (send text change-style style (car r) (cdr r)))
      
      (define/public (refresh)
        (send* text 
          (begin-edit-sequence)
          (lock #f)
          (change-style unhighlight-d 0 (send text last-position)))
        (for-each (lambda (hi-stx)
                    (let ([rs (send range get-ranges hi-stx)]
                          [hi-sd (highlight-style-delta highlight-color #f)])  ;; #t for bold
                      (for-each (lambda (r) (restyle-range r hi-sd)) rs)))
                  highlighted-syntaxes)
        (when selected-syntax
          (let ([rs (send range get-ranges selected-syntax)])
            (when (identifier? selected-syntax)
              (let ([partition (send controller get-secondary-partition)])
                (when partition
                  (for-each (lambda (id)
                              (when (send partition same-partition? selected-syntax id)
                                (draw-secondary-connection id)))
                            identifier-list))))
            (for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
        (send* text
          (lock #t)
          (end-edit-sequence)))

      (define/private (draw-secondary-connection stx2)
        (let ([rs (send range get-ranges stx2)])
          (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))

      (define/private (syntax->style-delta stx)
        (let ([delta (new style-delta%)])
          (let ([n (send color-partition get-partition stx)])
            (cond [((send controller get-administrative-predicate) stx)
                   (send delta set-delta-foreground "gray")]
                  [(< n (length colors))
                   (send delta set-delta-foreground (list-ref colors n))]
                  [else
                   (begin (send* delta
                            (set-delta-foreground "white")
                            (set-delta-background "black")))]))
          delta))
      
      (define/private (draw-primary-partition)
        (send text lock #f)
        (for-each 
         (lambda (range)
           (let ([stx (range-obj range)]
                 [start (range-start range)]
                 [end (range-end range)])
             (when (or primary-color-all-syntax? (identifier? stx))
               (send text change-style (syntax->style-delta stx) start end))))
         (send range all-ranges))
        #;(send color-partition dump)
        (send text lock #t))
      (draw-primary-partition)
      (super-new)))

  (define (highlight-style-delta color em?)
    (let ([sd (new style-delta%)])
      (unless em? (send sd set-delta-background color))
      (when em? 
        #;(send sd set-underlined-on #t)
        (send sd set-weight-on 'bold))
      (unless em?
        #;(send sd set-underlined-off #t)
        (send sd set-weight-off 'bold))
      sd))
  
  (define select-highlight-d (highlight-style-delta "lightgray" #f))
  (define select-sub-highlight-d (highlight-style-delta "lightblue" #f))
  (define unhighlight-d (highlight-style-delta "white" #f))
  
  )