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

  (define syntax-snip-colorer%
    (class object%
      (init-field snip)
      (init-field syntax-pp)
      (init-field controller)
      (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/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 (refresh)
        (if selected-syntax
            (show-selected-syntax selected-syntax)
            (show-nothing)))

      (define/private (show-nothing)
        (send* text
          (begin-edit-sequence)
          (lock #f)
          (change-style unhighlight-d 0 (send text last-position))
          (lock #t)
          (end-edit-sequence)))
      
      (define/private (show-selected-syntax stx)
        (let* ([rs (send range get-ranges stx)])
          (send* text 
            (begin-edit-sequence)
            (lock #f)
            (change-style unhighlight-d 0 (send text last-position)))
          (when (identifier? stx)
            (let ([partition (send controller get-secondary-partition)])
              (for-each (lambda (id)
                          (when (send partition same-partition? stx id)
                            (draw-secondary-connection stx id)))
                        identifier-list)))
          (for-each (lambda (r)
                      (send text change-style highlight-d (car r) (cdr r)))
                    rs)
          (send* text
            (lock #t)
            (end-edit-sequence))))

      (define/private (draw-secondary-connection stx1 stx2)
        (let ([rs (send range get-ranges stx2)])
          (for-each (lambda (r)
                      (send text change-style highlight2-d 
                            (car r) (cdr r)))
                    rs)))

      (define/private (syntax->style-delta stx)
        (let ([delta (new style-delta%)])
          (let ([n (send color-partition get-partition stx)])
            (if (< n (length colors))
                (send delta set-delta-foreground (list-ref colors n))
                (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)])
             (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-values (highlight-d highlight2-d unhighlight-d)
    (let ((h (new style-delta%))
          (h2 (new style-delta%))
          (uh (new style-delta%)))
      (send h set-delta-background "lightgray")
      (send h2 set-delta-background "lightblue")
      (send uh set-delta-background "white")
      (values h h2 uh)))
  
  )