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