Component representation for symbols.

alloy.asd

@@ -46,7 +46,8 @@ Author: Nicolas Hafner <shinmera@tymoon.eu>
                              (:file "scroll")
                              (:file "plot")
                              (:file "drag")
-                             (:file "wheel")))
+                             (:file "wheel")
+                             (:file "symbol")))
                (:module "structures"
                 :components ((:file "query")
                              (:file "scroll-view")

components/symbol.lisp

@@ -0,0 +1,74 @@
+#|
+ This file is a part of Alloy
+ (c) 2019 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
+ Author: Nicolas Hafner <shinmera@tymoon.eu>
+|#
+
+(in-package #:org.shirakumo.alloy)
+
+(defclass symb (input-line filtered-text-input validated-text-input transformed-text-input)
+  ((constrained-package :initform NIL :initarg :package :accessor constrained-package)
+   (allow-interning :initform NIL :initarg :allow-interning :accessor allow-interning)))
+
+(defmethod component-class-for-object ((symbol symbol)) (find-class 'symb))
+
+(defmethod accept-character ((symb symb) c &optional (state (list NIL NIL)))
+  (destructuring-bind (escaped colon) state
+    (cond (escaped
+           (values T (list NIL colon)))
+          ((char= #\\ c)
+           (values T (list T colon)))
+          ((char= #\: c)
+           (if (constrained-package symb)
+               (values NIL (list NIL T))
+               (values (not colon) (list NIL T))))
+          (T
+           (values T (list NIL colon))))))
+
+(defun parse-symbol-designator (text)
+  (with-input-from-string (in text)
+    (let (colon)
+      (flet ((process ()
+               (setf colon NIL)
+               (with-output-to-string (*standard-output*)
+                 (loop for c = (read-char in NIL)
+                       while c
+                       do (case c
+                            (#\\ (write-char (or (read-char in NIL) #\NUL)))
+                            (#\: (setf colon T) (return))
+                            (T (write-char c)))))))
+        (let ((package/name (process))
+              (package NIL))
+          (when colon
+            (setf package (if (string= "" package/name) "KEYWORD" package/name))
+            (setf package/name (process)))
+          (list package package/name))))))
+
+(defmethod valid-p ((symb symb) text)
+  (and (call-next-method)
+       (destructuring-bind (package name) (parse-symbol-designator text)
+         (and (if (constrained-package symb)
+                  (null package)
+                  (find-package package))
+              (or (allow-interning symb)
+                  (find-symbol name (or (constrained-package symb) package)))))))
+
+(defmethod value->text ((symb symb) symbol)
+  (with-output-to-string (*standard-output*)
+    (flet ((out (s)
+             (loop for c across s
+                   do (case c
+                        (#\\ (write-char #\\))
+                        (#\: (write-char #\\)))
+                      (write-char c))))
+      (unless (constrained-package symb)
+        (unless (eq (symbol-package symbol) (find-package "KEYWORD"))
+          (out (package-name (symbol-package symbol))))
+        (write-char #\:))
+      (out (symbol-name symbol)))))
+
+(defmethod text->value ((symb symb) text)
+  (destructuring-bind (package name) (parse-symbol-designator text)
+    (if (allow-interning symb)
+        (intern name (or (constrained-package symb) package))
+        (find-symbol name (or (constrained-package symb) package)))))

package.lisp

@@ -85,12 +85,23 @@
   ;; components/text-input.lisp
   (:export
    #:text-input-component
+   #:accept
+   #:reject
    #:text
    #:insert-mode
    #:cursor
    #:pos
    #:anchor
    #:insert-text
+   #:filtered-text-input
+   #:accept-character
+   #:filter-text
+   #:validated-text-input
+   #:valid-p
+   #:transformed-text-input
+   #:previous-value
+   #:value->text
+   #:text->value
    #:input-line
    #:accept
    #:input-box)
@@ -111,6 +122,11 @@
    #:maximum
    #:slider-unit
    #:ranged-slider)
+  ;; components/symbol.lisp
+  (:export
+   #:symb
+   #:constrained-package
+   #:allow-interning)
   ;; components/wheel.lisp
   (:export
    #:wheel

renderers/simple/presentations/default.lisp

@@ -115,6 +115,15 @@
   (:label
    :text (alloy:text alloy:renderable)))
 
+(define-realization (default-look-and-feel alloy:validated-text-input T)
+  ((:invalid-marker simple:rectangle)
+   (alloy:extent 0 -2 (alloy:pw 1) 2)
+   :pattern colors:red))
+
+(define-update (default-look-and-feel alloy:validated-text-input)
+  (:invalid-marker
+   :hidden-p (alloy:valid-p alloy:renderable (alloy:text alloy:renderable))))
+
 (define-realization (default-look-and-feel alloy:slider)
   ((:background simple:rectangle)
    (ecase (alloy:orientation alloy:renderable)