From 699b8ec8e807b18af3de508eae027407e44672f9 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Sat, 9 Aug 2025 23:26:42 +0200 Subject: [PATCH] Ellipsis in the middle supported --- info.rkt | 2 +- main.rkt | 127 ++++++++++++++++++++++++++------- scribblings/ellipsis-msg.scrbl | 46 ++++++++++-- 3 files changed, 141 insertions(+), 34 deletions(-) diff --git a/info.rkt b/info.rkt index 65deb2b..3201879 100644 --- a/info.rkt +++ b/info.rkt @@ -1,7 +1,7 @@ #lang info (define pkg-authors '(hnmdijkema)) -(define version "0.1.2") +(define version "0.1.3") (define license 'Apache-2.0) (define collection "ellipsis-msg") (define pkg-desc "A message% with ellipsis (...) to the left or right") diff --git a/main.rkt b/main.rkt index 7120b0a..6fcdc41 100644 --- a/main.rkt +++ b/main.rkt @@ -1,38 +1,68 @@ #lang racket (require racket/gui) -(require (prefix-in str: srfi/13)) (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% (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 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) - (let ((ext (call-with-values (lambda () (get-window-text-extent l font)) - (lambda (w h) w)))) - ;(printf "label: ~a, max-w: ~a, w: ~a\n" l w ext) + (let* ((ext (call-with-values + (lambda () (get-window-text-extent l font)) + (lambda (w h) w)))) (if (or (< w 10) (<= ext w) (string=? l "")) (if (eq? ellipsis 'right) - (string-append (str:string-drop-right l 3) "...") - (string-append "..." (str:string-drop l 3))) + (string-append (string-drop-right l 3) "...") + (string-append "..." (string-drop l 3))) (let* ((factor (/ w ext)) (strl (string-length l)) (n-strl (round (* strl factor))) (drop (- strl n-strl))) - (when (= drop 0) - (set! drop 1)) + (when (= drop 0) (set! drop 1)) (if (eq? ellipsis 'left) - (let ((nl (str:string-drop l drop))) - (ellipsize w (str:string-drop l drop))) - (let ((nl (str:string-drop-right l drop))) - (ellipsize w (str:string-drop-right l drop)))))))) + (let ((nl (string-drop l drop))) + (ellipsize w (string-drop l drop))) + (let ((nl (string-drop-right l drop))) + (ellipsize w (string-drop-right l drop)))) + )))) (define/override (set-label l . resize) (let ((rsz #f)) @@ -41,19 +71,27 @@ (if (eq? rsz #t) (super set-label l) (let* ((width (send this get-width)) - (ext (call-with-values (lambda () (get-window-text-extent l font)) - (lambda (w h) w))) + (ext (call-with-values + (lambda () (get-window-text-extent l font)) + (lambda (w h) w))) ) (set! my_label l) - ;(printf "Ellipsis = ~a\n" ellipsis) (set! ellipsis_label (if (< ext width) l - (ellipsize width (string-append - (if (eq? ellipsis 'left) "..." "") - l - (if (eq? ellipsis 'right) "..." ""))))) - ;(printf "Setting label to ~a\n" ellipsis_label) + (if (eq? ellipsis 'middle) + (let ((middle (inexact->exact + (round + (/ (string-length l) 2.0))))) + (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))))) (define/override (get-label) @@ -61,13 +99,48 @@ )) + ;(require racket/gui) ;(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 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 lbl1 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp1] [ellipsis 'right] [auto-resize #t] [stretchable-width #t])) +;(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 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 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 lbl2 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp2] [ellipsis 'left] [auto-resize #t] [stretchable-width #t])) +;(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 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) diff --git a/scribblings/ellipsis-msg.scrbl b/scribblings/ellipsis-msg.scrbl index ff93206..3c2c961 100644 --- a/scribblings/ellipsis-msg.scrbl +++ b/scribblings/ellipsis-msg.scrbl @@ -27,7 +27,7 @@ See also @racket[message%]. (or/c 'app 'caution 'stop))] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) (is-a?/c panel%) (is-a?/c pane%))] - [ellipsis symbol? 'right] + [ellipsis (or/c '(left middle right)) 'right] [style (listof (or/c 'deleted)) null] [font (is-a?/c font%) normal-control-font] [color (or/c #f string? (is-a?/c color%)) #f] @@ -54,13 +54,47 @@ See also @racket[message%]. [racketblock (require racket/gui) (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 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 lbl1 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp1] [ellipsis 'right] [auto-resize #t] [stretchable-width #t])) + (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 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 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 lbl2 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp2] [ellipsis 'left] [auto-resize #t] [stretchable-width #t])) + (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 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) ]