90 lines
2.9 KiB
Racket
90 lines
2.9 KiB
Racket
#lang scheme/base
|
|
|
|
(provide get-string/style-desc)
|
|
(require scheme/gui/base
|
|
scheme/class)
|
|
|
|
;; get-string/style-desc : text -> (listof str/ann)
|
|
(define (get-string/style-desc text [start 0] [end (send text last-position)])
|
|
(let* ([snips (get-snips text start end)]
|
|
[str/ann (map snip->str/ann snips)]
|
|
[joined-str/ann (join-like str/ann)])
|
|
joined-str/ann))
|
|
|
|
;; get-snips : text -> (listof snip)
|
|
;; extracts the snips from a text
|
|
(define (get-snips text start end)
|
|
(send text split-snip start)
|
|
(send text split-snip end)
|
|
(let loop ([snip (send text find-snip start 'after-or-none)])
|
|
(cond
|
|
[(not snip) null]
|
|
[(< (send text get-snip-position snip) end)
|
|
(cons snip (loop (send snip next)))]
|
|
[else null])))
|
|
|
|
;; snip->str/ann : snip -> str/ann
|
|
;; extracts the style type from the snip
|
|
(define (snip->str/ann snip)
|
|
(let* ([str (cond
|
|
[(is-a? snip string-snip%)
|
|
(send snip get-text 0 (send snip get-count))]
|
|
[(is-a? snip image-snip%)
|
|
'image]
|
|
[else 'unknown])]
|
|
[style (send snip get-style)]
|
|
[style-name (send style get-name)]
|
|
[style-desc (if style-name
|
|
(translate-name style-name)
|
|
(describe-style style))])
|
|
(list str style-desc)))
|
|
|
|
;; describe-style : style -> (listof symbol)
|
|
(define (describe-style style)
|
|
(list
|
|
'alignment (send style get-alignment)
|
|
'background (symbolic-color (send style get-background))
|
|
'face (send style get-face)
|
|
'family (send style get-family)
|
|
'foreground (symbolic-color (send style get-foreground))
|
|
'size (send style get-size)
|
|
'underlined (send style get-underlined)))
|
|
|
|
(define (symbolic-color color)
|
|
(list (send color red)
|
|
(send color green)
|
|
(send color blue)))
|
|
|
|
;; translate-name : (union #f string) -> symbol
|
|
;; translates the style name to a symbol
|
|
(define (translate-name str)
|
|
(and str
|
|
(let ([m (regexp-match re:translate-name str)])
|
|
(and m
|
|
(string->symbol (cadr m))))))
|
|
|
|
;; re:translate-name : regexp
|
|
(define re:translate-name (regexp "^.*:([^:]*)$"))
|
|
|
|
;; join-like : (listof str/ann) -> (listof str/ann)
|
|
;; joins same styles to form largest groups
|
|
(define (join-like str/anns)
|
|
(cond
|
|
[(null? str/anns) null]
|
|
[else
|
|
(let loop ([first (car str/anns)]
|
|
[rest (cdr str/anns)])
|
|
(cond
|
|
[(null? rest) (list first)]
|
|
[else
|
|
(let ([second (car rest)])
|
|
(if (and (equal? (cadr first) (cadr second))
|
|
(string? (car first))
|
|
(string? (car second)))
|
|
(loop (list (string-append (car first) (car second))
|
|
(cadr first))
|
|
(cdr rest))
|
|
(cons first
|
|
(loop second
|
|
(cdr rest)))))]))]))
|