diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..bed1e52 --- /dev/null +++ b/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")) + diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..c44f977 --- /dev/null +++ b/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) + )) \ No newline at end of file diff --git a/scribblings/ellipsis-msg.scrbl b/scribblings/ellipsis-msg.scrbl new file mode 100644 index 0000000..bef0d8a --- /dev/null +++ b/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) +} + +} +