suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

drdr-ized the rest of the drscheme test suite

Browse Source 
svn: r17945

original commit: e74e46d9ca0b6b6536c4774f2978c515574f958a
This commit is contained in:
Robby Findler 2010-02-02 21:06:07 +00:00
parent 798e2fad54
commit 17ffda440e
1 changed files with 87 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

175
collects/mrlib/text-string-style-desc.ss
View File

@ -1,90 +1,89 @@
(module text-string-style-desc mzscheme
(provide get-string/style-desc)
(require mred
mzlib/etc
mzlib/class)
;; get-string/style-desc : text -> (listof str/ann)
(define get-string/style-desc
(opt-lambda (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)))
#lang scheme/base
;; 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)
(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
[(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)))))]))])))
[(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)))))]))]))