hans/ellipsis-msg
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ellipsis in the middle supported

Browse Source
This commit is contained in:
Hans Dijkema
2025-08-09 23:26:42 +02:00
parent 947f2e26b1
commit 699b8ec8e8
3 changed files with 141 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
info.rkt
View File

@@ -1,7 +1,7 @@
#lang info #lang info
(define pkg-authors '(hnmdijkema)) (define pkg-authors '(hnmdijkema))
(define version "0.1.2") (define version "0.1.3")
(define license 'Apache-2.0) (define license 'Apache-2.0)
(define collection "ellipsis-msg") (define collection "ellipsis-msg")
(define pkg-desc "A message% with ellipsis (...) to the left or right") (define pkg-desc "A message% with ellipsis (...) to the left or right")

127
main.rkt
View File

@@ -1,38 +1,68 @@
#lang racket #lang racket
(require racket/gui) (require racket/gui)
(require (prefix-in str: srfi/13))
(provide ellipsis-msg%) (provide ellipsis-msg%)
(define (string-drop s n)
(let ((l (string-length s)))
(if (>= n l)
""
(substring s n))))
(define (string-drop-right s n)
(let ((l (string-length s)))
(if (>= n l)
""
(substring s 0 (- l n))
)))
(define ellipsis-msg% (define ellipsis-msg%
(class message% (class message%
(super-new)
(init-field [font normal-control-font] [ellipsis 'right]) (init-field [ellipsis 'right]
[font normal-control-font])
(super-new [font font])
(define my_label "") (define my_label "")
(define ellipsis_label "") (define ellipsis_label "")
(define/private (ellipsize-middle w l r)
(let* ((str (string-append l "..." r))
(ext (call-with-values
(lambda () (get-window-text-extent str font))
(lambda (w h) w))))
(if (or (< w 10) (<= ext w) (string=? l "") (string=? r ""))
(string-append l "..." r)
(let* ((factor (/ w ext))
(strl (+ (string-length l) (string-length r)))
(n-strl (round (* strl factor)))
(drop (- strl n-strl))
(drop-l (inexact->exact (round (/ drop 2.0))))
(drop-r (- drop drop-l)))
(ellipsize-middle w
(string-drop-right l drop-l)
(string-drop r drop-r))))))
(define/private (ellipsize w l) (define/private (ellipsize w l)
(let ((ext (call-with-values (lambda () (get-window-text-extent l font)) (let* ((ext (call-with-values
(lambda (w h) w)))) (lambda () (get-window-text-extent l font))
;(printf "label: ~a, max-w: ~a, w: ~a\n" l w ext) (lambda (w h) w))))
(if (or (< w 10) (<= ext w) (string=? l "")) (if (or (< w 10) (<= ext w) (string=? l ""))
(if (eq? ellipsis 'right) (if (eq? ellipsis 'right)
(string-append (str:string-drop-right l 3) "...") (string-append (string-drop-right l 3) "...")
(string-append "..." (str:string-drop l 3))) (string-append "..." (string-drop l 3)))
(let* ((factor (/ w ext)) (let* ((factor (/ w ext))
(strl (string-length l)) (strl (string-length l))
(n-strl (round (* strl factor))) (n-strl (round (* strl factor)))
(drop (- strl n-strl))) (drop (- strl n-strl)))
(when (= drop 0) (when (= drop 0) (set! drop 1))
(set! drop 1))
(if (eq? ellipsis 'left) (if (eq? ellipsis 'left)
(let ((nl (str:string-drop l drop))) (let ((nl (string-drop l drop)))
(ellipsize w (str:string-drop l drop))) (ellipsize w (string-drop l drop)))
(let ((nl (str:string-drop-right l drop))) (let ((nl (string-drop-right l drop)))
(ellipsize w (str:string-drop-right l drop)))))))) (ellipsize w (string-drop-right l drop))))
))))
(define/override (set-label l . resize) (define/override (set-label l . resize)
(let ((rsz #f)) (let ((rsz #f))
@@ -41,19 +71,27 @@
(if (eq? rsz #t) (if (eq? rsz #t)
(super set-label l) (super set-label l)
(let* ((width (send this get-width)) (let* ((width (send this get-width))
(ext (call-with-values (lambda () (get-window-text-extent l font)) (ext (call-with-values
(lambda (w h) w))) (lambda () (get-window-text-extent l font))
(lambda (w h) w)))
) )
(set! my_label l) (set! my_label l)
;(printf "Ellipsis = ~a\n" ellipsis)
(set! ellipsis_label (set! ellipsis_label
(if (< ext width) (if (< ext width)
l l
(ellipsize width (string-append (if (eq? ellipsis 'middle)
(if (eq? ellipsis 'left) "..." "") (let ((middle (inexact->exact
l (round
(if (eq? ellipsis 'right) "..." ""))))) (/ (string-length l) 2.0)))))
;(printf "Setting label to ~a\n" ellipsis_label) (ellipsize-middle width
(substring l 0 middle)
(substring l middle)))
(ellipsize
width
(string-append
(if (eq? ellipsis 'left) "..." "")
l
(if (eq? ellipsis 'right) "..." ""))))))
(super set-label ellipsis_label))))) (super set-label ellipsis_label)))))
(define/override (get-label) (define/override (get-label)
@@ -61,13 +99,48 @@
)) ))
;(require racket/gui) ;(require racket/gui)
;(require ellipsis-msg) ;(require ellipsis-msg)
;(define win (new frame% [label "Hi there!"])) ;(define win (new frame% [label "Hi there!"] [width 300]))
;
;(define hp1 (new horizontal-pane% [parent win])) ;(define hp1 (new horizontal-pane% [parent win]))
;(define btn1 (new button% [label "Longer 1"] [parent hp1] [callback (lambda (b e) (send lbl1 set-label "This is a very long text, yes a longer text than we initial put"))])) ;(define btn1 (new button% [label "Longer 1"] [parent hp1]
;(define lbl1 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp1] [ellipsis 'right] [auto-resize #t] [stretchable-width #t])) ; [callback
; (lambda (b e)
; (send lbl1 set-label
; "This is a very long text, yes a longer text than we initial put"))]
; ))
;(define lbl1 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp1]
; [ellipsis 'right] [auto-resize #t] [stretchable-width #t]))
;
;(define hp2 (new horizontal-pane% [parent win])) ;(define hp2 (new horizontal-pane% [parent win]))
;(define btn2 (new button% [label "Longer 2"] [parent hp2] [callback (lambda (b e) (send lbl2 set-label "This is a very long second text, yes a longer text than we initial put"))])) ;(define btn2 (new button% [label "Longer 2"] [parent hp2]
;(define lbl2 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp2] [ellipsis 'left] [auto-resize #t] [stretchable-width #t])) ; [callback
; (lambda (b e)
; (send lbl2 set-label
; "This is a very long second text, yes a longer text than we initial put"))]
; ))
;(define lbl2 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp2]
; [ellipsis 'left] [auto-resize #t] [stretchable-width #t]))
;
;
;(define hp3 (new horizontal-pane% [parent win]))
;(define btn3 (new button% [label "Longer 3"] [parent hp3]
; [callback
; (lambda (b e)
; (send lbl3 set-label
; "This is a third very long text, yes much longer than the initial text"))]
; ))
;(define lbl3 (new ellipsis-msg% [label "This is label 3"] [parent hp3]
; [ellipsis 'middle] [auto-resize #t] [stretchable-width #t]
; [font (make-object font% 12 'default)]
; ))
;
;(define hp4 (new horizontal-pane% [parent win]))
;(define lbl4 (new message% [label "This is label 4"] [parent hp4]
; [auto-resize #t] [stretchable-width #t]
; [font (make-object font% 12 'default)]
; ))
;
;(send win show #t) ;(send win show #t)

46
scribblings/ellipsis-msg.scrbl
View File

@@ -27,7 +27,7 @@ See also @racket[message%].
(or/c 'app 'caution 'stop))] (or/c 'app 'caution 'stop))]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) [parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
(is-a?/c panel%) (is-a?/c pane%))] (is-a?/c panel%) (is-a?/c pane%))]
[ellipsis symbol? 'right] [ellipsis (or/c '(left middle right)) 'right]
[style (listof (or/c 'deleted)) null] [style (listof (or/c 'deleted)) null]
[font (is-a?/c font%) normal-control-font] [font (is-a?/c font%) normal-control-font]
[color (or/c #f string? (is-a?/c color%)) #f] [color (or/c #f string? (is-a?/c color%)) #f]
@@ -54,13 +54,47 @@ See also @racket[message%].
[racketblock [racketblock
(require racket/gui) (require racket/gui)
(require ellipsis-msg) (require ellipsis-msg)
(define win (new frame% [label "Hi there!"])) (define win (new frame% [label "Hi there!"] [width 300]))
(define hp1 (new horizontal-pane% [parent win])) (define hp1 (new horizontal-pane% [parent win]))
(define btn1 (new button% [label "Longer 1"] [parent hp1] [callback (lambda (b e) (send lbl1 set-label "This is a very long text, yes a longer text than we initial put"))])) (define btn1 (new button% [label "Longer 1"] [parent hp1]
(define lbl1 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp1] [ellipsis 'right] [auto-resize #t] [stretchable-width #t])) [callback
(lambda (b e)
(send lbl1 set-label
"This is a very long text, yes a longer text than we initial put"))]
))
(define lbl1 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp1]
[ellipsis 'right] [auto-resize #t] [stretchable-width #t]))
(define hp2 (new horizontal-pane% [parent win])) (define hp2 (new horizontal-pane% [parent win]))
(define btn2 (new button% [label "Longer 2"] [parent hp2] [callback (lambda (b e) (send lbl2 set-label "This is a very long second text, yes a longer text than we initial put"))])) (define btn2 (new button% [label "Longer 2"] [parent hp2]
(define lbl2 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp2] [ellipsis 'left] [auto-resize #t] [stretchable-width #t])) [callback
(lambda (b e)
(send lbl2 set-label
"This is a very long second text, yes a longer text than we initial put"))]
))
(define lbl2 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp2]
[ellipsis 'left] [auto-resize #t] [stretchable-width #t]))
(define hp3 (new horizontal-pane% [parent win]))
(define btn3 (new button% [label "Longer 3"] [parent hp3]
[callback
(lambda (b e)
(send lbl3 set-label
"This is a third very long text, yes much longer than the initial text"))]
))
(define lbl3 (new ellipsis-msg% [label "This is label 3"] [parent hp3]
[ellipsis 'middle] [auto-resize #t] [stretchable-width #t]
[font (make-object font% 12 'default)]
))
(define hp4 (new horizontal-pane% [parent win]))
(define lbl4 (new message% [label "This is label 4"] [parent hp4]
[auto-resize #t] [stretchable-width #t]
[font (make-object font% 12 'default)]
))
(send win show #t) (send win show #t)
] ]