initial

info.rkt

@@ -0,0 +1,22 @@
+#lang info
+
+(define pkg-authors '(hnmdijkema))
+(define version "0.1.0")
+(define license 'Apache-2.0)
+(define collection "ellipsis-msg")
+(define pkg-desc "A message% with ellipsis (...) to the left or right")
+
+(define scribblings
+  '(
+    ("scribblings/ellipsis-msg.scrbl" () (gui) "ellipsis-msg")
+    )
+  )
+
+(define deps
+  '("racket/gui"))
+
+(define build-deps
+  '("racket-doc"
+    "rackunit-lib"
+    "scribble-lib"))
+

main.rkt

@@ -0,0 +1,49 @@
+#lang racket
+
+(provide ellipsis-msg%)
+
+(define ellipsis-msg%
+    (class message%
+      (super-new)
+
+      (init-field [font normal-control-font] [ellipsis 'right])
+
+      (define my_label "")
+      (define ellipsis_label "")
+
+      (define/private (ellipsize w l)
+        (let ((ext (call-with-values (lambda () (get-window-text-extent l font))
+                                          (lambda (w h) w))))
+          (if (< ext w)
+              l
+              (let* ((factor (/ w ext))
+                     (strl   (string-length l))
+                     (n-strl (round (* strl factor)))
+                     (drop   (- strl n-strl)))
+                (if (eq? ellipsis 'right)
+                    (ellipsize w (str:string-drop l drop))
+                    (ellipsize w (str:string-drop-right l drop)))))))
+      
+      (define/override (set-label l . resize)
+        (let ((rsz #f))
+          (unless (null? resize)
+            (set! rsz (car resize)))
+          (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)))
+                   )
+              (set! my_label l)
+              (set! ellipsis_label
+                    (if (< ext width)
+                        l
+                        (ellipsize width (string-append
+                                            (if (eq? ellipsis 'left) "..." "")
+                                            l
+                                            (if (eq? ellipsis 'right) "..." "")))))
+              (super set-label ellipsis_label)))))
+      
+      (define/override (get-label)
+        my_label)
+      ))

scribblings/ellipsis-msg.scrbl

@@ -0,0 +1,44 @@
+#lang scribble/manual
+
+@(require
+   scribble/example
+   (for-label racket/gui
+              )
+  @(for-label ellipsis-msg))
+
+@title[#:tag "ellipsis-msg"]{A message% with ellipsis (...) to the left or right}
+
+@author[@author+email["Hans Dijkema" "hans@dijkewijk.nl"]]
+
+@defmodule[ellipsis-msg]
+This module provides a new class @racket[ellipsis-msg%] that will cut the label of with ellipsis (...) when it is too long
+for the current width. The @racket[ellipsis] parameter tells where to put the ellipsis. 
+
+@defclass[columns-pane% vertical-pane% ()]{
+
+A columns pane arranges its subwindows in columns. The number of columns must be given in advance and initializes to 1.
+See also @racket[pane%].
+
+@defconstructor[([label (or/c label-string?)]
+                 [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) 
+                               (is-a?/c panel%) (is-a?/c pane%))]
+                 [[ellipsis symbol? 'right]
+                  [font (is-a/c font%) normal-control-font]
+                  [auto-resize boolean? #f]
+                  [color (or/c #f string? (is-a?/c color%)) #f]
+                  [enabled any/c #t]
+                  [vert-margin spacing-integer? 0]
+                  [horiz-margin spacing-integer? 0]
+                  [min-width (or/c dimension-integer? #f) #f]
+                  [min-height (or/c dimension-integer? #f) #f]
+                  [stretchable-width any/c #t]
+                  [stretchable-height any/c #t]]
+                  )]{
+}
+
+@defmethod*[([(set-label (label string?) [resize or/c boolean? default #f])])]{
+ Sets the message label. If resize = #t, the label will be resized (if auto-resize = #t)
+}
+
+}
+