(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]))
(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)))
(define (extend-style-map base styles)
(new extended-style-map% (base base) (styles styles)))
(define empty-style-map
(new empty-style-map%))
(define basic-style-map
(extend-style-map empty-style-map
basic-styles))
(define schemeunit-style-map
(extend-style-map basic-style-map
schemeunit-styles))
)