diff --git a/alloy.asd b/alloy.asd index 8497e00..48ab4de 100644 --- a/alloy.asd +++ b/alloy.asd @@ -46,7 +46,8 @@ Author: Nicolas Hafner (:file "scroll") (:file "plot") (:file "drag") - (:file "wheel"))) + (:file "wheel") + (:file "symbol"))) (:module "structures" :components ((:file "query") (:file "scroll-view") diff --git a/components/symbol.lisp b/components/symbol.lisp new file mode 100644 index 0000000..de1f711 --- /dev/null +++ b/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 +|# + +(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))))) diff --git a/package.lisp b/package.lisp index 92a56c0..524badc 100644 --- a/package.lisp +++ b/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 diff --git a/renderers/simple/presentations/default.lisp b/renderers/simple/presentations/default.lisp index abfc01e..21dc7b6 100644 --- a/renderers/simple/presentations/default.lisp +++ b/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)