gui/rml-styles.ss
(module rml-styles mzscheme
  (require (lib "mred.ss" "mred")
           (lib "class.ss")
           "interfaces.ss")
  (provide empty-style-map
           basic-style-map
           schemeunit-style-map
           extend-style-map)
  
  (define style:no-change (make-object style-delta% 'change-nothing))
  (define style:normal (make-object style-delta% 'change-normal))
  (define style:large (make-object style-delta% 'change-nothing))
  (send style:large set-size-mult 1.5)

  (define style:blue (make-object style-delta% 'change-nothing))
  (send style:blue set-delta-foreground "Blue")
  (define style:red (make-object style-delta% 'change-nothing))
  (send style:red set-delta-foreground "Red")
  (define style:green (make-object style-delta% 'change-nothing))
  (send style:green set-delta-foreground "ForestGreen")
  (define style:purple (make-object style-delta% 'change-nothing))
  (send style:purple set-delta-foreground "Purple")
  (define style:gray (make-object style-delta% 'change-nothing))
  (send style:gray set-delta-foreground "DimGray")
  (define style:darkblue (make-object style-delta% 'change-nothing))
  (send style:darkblue set-delta-foreground "DarkBlue")
  
  (define style:clickback (make-object style-delta% 'change-underline #t))
  (send style:clickback set-delta-foreground "blue")
  
  (define style:bold (make-object style-delta% 'change-nothing))
  (send style:bold set-delta 'change-weight 'bold)
  (define style:italic (make-object style-delta% 'change-nothing))
  (send style:italic set-delta 'change-style 'italic)

  (define basic-styles
    `([no-change . ,style:no-change]
      [normal    . ,style:normal]
      [large     . ,style:large]
      [clickback . ,style:clickback]
      [red       . ,style:red]
      [blue      . ,style:blue]
      [green     . ,style:green]
      [purple    . ,style:purple]
      [darkblue  . ,style:darkblue]
      [bold      . ,style:bold]
      [italic    . ,style:italic]
      [error     . ,style:red]
      [value     . ,style:darkblue]))
  
  (define schemeunit-styles
    `([test-unexecuted . ,style:gray]
      [test-success    . ,style:green]
      [test-failure    . ,style:red]
      [test-error      . ,style:red]
      
      [exn-type        . ,style:darkblue]
      [exn-message     . ,style:red]
      [exn-value       . ,style:darkblue]
      [fail-type       . ,style:darkblue]))
  
  
  ;; -- style-map classes

  (define extended-style-map%
    (class* object% (style-map<%>)
      (init-field styles
                  base)
      (define/public (get-style sym)
        (cond [(assq sym styles) => cdr]
              [else (send base get-style sym)]))
      (super-new)))
  
  (define empty-style-map%
    (class* object% (style-map<%>)
      (define/public (get-style sym)
        (error 'get-style "unknown style: ~s" sym))
      (super-new)))
  
  ;; extend-style-map : style-map<%> styles -> style-map<%>
  (define (extend-style-map base styles)
    (new extended-style-map% (base base) (styles styles)))

  ;; empty-style-map : style-map<%>
  (define empty-style-map
    (new empty-style-map%))
  
  ;; basic-style-map : style-map<%>
  (define basic-style-map
    (extend-style-map empty-style-map
                      basic-styles))
  
  ;; schemeunit-style-map : style-map<%>
  (define schemeunit-style-map
    (extend-style-map basic-style-map 
                      schemeunit-styles))
    
  )