Compare commits
6 Commits
4c3f5fe65a
...
94df17a7b9
| Author | SHA1 | Date | |
|---|---|---|---|
| 94df17a7b9 | |||
| ef26220df7 | |||
| 4e54737659 | |||
| 4e0b825fcc | |||
| e53939844c | |||
| 9b8ac8b770 |
@@ -63,8 +63,9 @@ subsystems. All public symbols are exported for user convenience.
|
|||||||
#:dialog-on-dismiss
|
#:dialog-on-dismiss
|
||||||
#:dialog-size
|
#:dialog-size
|
||||||
#:dialog-size-pixels
|
#:dialog-size-pixels
|
||||||
#:render-dialog
|
#:render-dialog
|
||||||
#:push-dialog
|
#:render-select-minibuffer
|
||||||
|
#:push-dialog
|
||||||
#:pop-dialog
|
#:pop-dialog
|
||||||
#:*dialog-stack*
|
#:*dialog-stack*
|
||||||
#:alert-dialog
|
#:alert-dialog
|
||||||
@@ -172,6 +173,58 @@ Content is rendered via ~draw-text~ inside the panel area.
|
|||||||
:white :default)))))
|
:white :default)))))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
||||||
|
** render-select-minibuffer
|
||||||
|
|
||||||
|
Renders a ~select~ widget as a bottom-anchored minibuffer panel at the
|
||||||
|
given position. The panel fills a rectangular area, draws a separator
|
||||||
|
line with the title at the top, the filtered options in the middle,
|
||||||
|
and a filter input line (>= ~...~) at the bottom. ~colors~ is a plist
|
||||||
|
with keys ~:bg-panel~, ~:separator~, ~:accent~, ~:text-muted~,
|
||||||
|
~:agent-fg~, ~:input-fg~, ~:bg-input~, ~:input-prompt~.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||||
|
(defun render-select-minibuffer (be x y width height select title colors)
|
||||||
|
(let* ((filtered (select-filtered-options select))
|
||||||
|
(sel-idx (or (select-selected-index select) 0))
|
||||||
|
(filter (select-filter select))
|
||||||
|
(bg-p (getf colors :bg-panel))
|
||||||
|
(sep-c (getf colors :separator)))
|
||||||
|
(dotimes (r height)
|
||||||
|
(draw-rect be x (+ y r) width 1 :bg bg-p))
|
||||||
|
(draw-text be x y (make-string width :initial-element #\─) sep-c bg-p)
|
||||||
|
(draw-text be (1+ x) y title (getf colors :accent) bg-p)
|
||||||
|
(loop for item in filtered
|
||||||
|
for i from 1
|
||||||
|
for display-idx = (first item)
|
||||||
|
for option = (third item)
|
||||||
|
for opt-title = (getf option :title)
|
||||||
|
for cat = (getf option :category)
|
||||||
|
for sel-p = (eql display-idx sel-idx)
|
||||||
|
for row = (+ y i)
|
||||||
|
while (< row (+ y (min height (length filtered))))
|
||||||
|
do (cond
|
||||||
|
(sel-p
|
||||||
|
(draw-rect be (1+ x) row (1- width) 1
|
||||||
|
:bg (getf colors :input-fg))
|
||||||
|
(draw-text be (1+ x) row
|
||||||
|
(format nil " >> ~a" opt-title)
|
||||||
|
(getf colors :bg-input)
|
||||||
|
(getf colors :input-fg)))
|
||||||
|
(cat
|
||||||
|
(draw-text be (1+ x) row
|
||||||
|
(format nil " ~a" opt-title)
|
||||||
|
(getf colors :text-muted) bg-p))
|
||||||
|
(t
|
||||||
|
(draw-text be (1+ x) row
|
||||||
|
(format nil " ~a" opt-title)
|
||||||
|
(getf colors :agent-fg) bg-p))))
|
||||||
|
(let ((filter-y (+ y (- height 3))))
|
||||||
|
(draw-rect be x filter-y width 1 :bg bg-p)
|
||||||
|
(draw-text be x filter-y
|
||||||
|
(format nil "> ~a" (or filter ""))
|
||||||
|
(getf colors :input-prompt) bg-p))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
** push-dialog
|
** push-dialog
|
||||||
|
|
||||||
Pushes a dialog onto =*dialog-stack*=. Returns the dialog for chaining.
|
Pushes a dialog onto =*dialog-stack*=. Returns the dialog for chaining.
|
||||||
|
|||||||
@@ -817,7 +817,7 @@ color.
|
|||||||
(line (concatenate 'string
|
(line (concatenate 'string
|
||||||
bg-esc
|
bg-esc
|
||||||
(make-string width :initial-element #\Space)
|
(make-string width :initial-element #\Space)
|
||||||
reset (string #\Newline))))
|
reset "")))
|
||||||
(loop :for row :from 0 :below height :do
|
(loop :for row :from 0 :below height :do
|
||||||
(backend-write b (cursor-move-escape x (+ y row)))
|
(backend-write b (cursor-move-escape x (+ y row)))
|
||||||
(backend-write b line))))
|
(backend-write b line))))
|
||||||
|
|||||||
@@ -203,7 +203,9 @@ via ~sb-posix~ directly.
|
|||||||
#:text-input #:make-text-input
|
#:text-input #:make-text-input
|
||||||
#:text-input-value #:text-input-cursor
|
#:text-input-value #:text-input-cursor
|
||||||
#:text-input-placeholder #:text-input-max-length
|
#:text-input-placeholder #:text-input-max-length
|
||||||
#:text-input-on-submit #:text-input-layout-node
|
#:text-input-on-submit #:text-input-on-cancel
|
||||||
|
#:text-input-on-tab #:text-input-on-history
|
||||||
|
#:text-input-layout-node
|
||||||
#:text-input-insert #:text-input-backspace #:text-input-delete
|
#:text-input-insert #:text-input-backspace #:text-input-delete
|
||||||
#:text-input-move-left #:text-input-move-right
|
#:text-input-move-left #:text-input-move-right
|
||||||
#:text-input-move-home #:text-input-move-end
|
#:text-input-move-home #:text-input-move-end
|
||||||
@@ -408,9 +410,10 @@ sequences where modifiers appear in a non-standard position.
|
|||||||
|
|
||||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
|
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
|
||||||
(defun parse-csi-params (params terminator extended)
|
(defun parse-csi-params (params terminator extended)
|
||||||
(let* ((key (if (find terminator '(#\~ #\u))
|
(let* ((terminator-char (code-char terminator))
|
||||||
|
(key (if (and terminator-char (find terminator-char '(#\~ #\u)))
|
||||||
(cdr (assoc (first params) *csi-tilde-table*))
|
(cdr (assoc (first params) *csi-tilde-table*))
|
||||||
(cdr (assoc terminator *csi-key-table*))))
|
(cdr (assoc terminator-char *csi-key-table*))))
|
||||||
(modifier (when (and (> (length params) 1) (not (find terminator '(#\~ #\u))))
|
(modifier (when (and (> (length params) 1) (not (find terminator '(#\~ #\u))))
|
||||||
(second params)))
|
(second params)))
|
||||||
(actual-modifier (when (> (length extended) 1) (second extended)))
|
(actual-modifier (when (> (length extended) 1) (second extended)))
|
||||||
@@ -430,7 +433,7 @@ sequences where modifiers appear in a non-standard position.
|
|||||||
:raw (string (code-char code))))
|
:raw (string (code-char code))))
|
||||||
(make-key-event :key (or key :unknown)
|
(make-key-event :key (or key :unknown)
|
||||||
:ctrl ctrl :alt alt :shift shift
|
:ctrl ctrl :alt alt :shift shift
|
||||||
:raw (format nil "~C[~{~d~};~d~C" #\Esc params terminator)))))
|
:raw (format nil "~C[~{~d~};~d" #\Esc params terminator)))))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
||||||
** Raw byte reader
|
** Raw byte reader
|
||||||
@@ -456,17 +459,37 @@ and manual ~free-alien~ while keeping the GC from moving the buffer
|
|||||||
during the ~unix-read~ syscall.
|
during the ~unix-read~ syscall.
|
||||||
|
|
||||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
|
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
|
||||||
|
(defun get-input-fd ()
|
||||||
|
"Return a file descriptor suitable for reading terminal input.
|
||||||
|
Prefers fd 0 (stdin) if it's a TTY, otherwise opens /dev/tty.
|
||||||
|
Falls back to fd 0 if /dev/tty is not available."
|
||||||
|
(or (and (sb-unix:unix-isatty 0) 0)
|
||||||
|
(handler-case
|
||||||
|
(let ((fd (sb-unix:unix-open "/dev/tty" sb-unix:o_rdonly)))
|
||||||
|
(if (and fd (>= fd 0)) fd 0))
|
||||||
|
(error () 0))))
|
||||||
|
|
||||||
(defun read-raw-byte (&key timeout)
|
(defun read-raw-byte (&key timeout)
|
||||||
(let* ((buf (make-array 1 :element-type '(unsigned-byte 8)))
|
(let* ((buf (make-array 1 :element-type '(unsigned-byte 8)))
|
||||||
(fd 0)
|
(fd-stream (get-input-fd))
|
||||||
(timeout-ms (when timeout (max 1 (round (* timeout 1000))))))
|
(timeout-ms (when timeout (max 1 (round (* timeout 1000))))))
|
||||||
(sb-sys:with-pinned-objects (buf)
|
(sb-sys:with-pinned-objects (buf)
|
||||||
(let ((sap (sb-sys:vector-sap buf)))
|
(let ((sap (sb-sys:vector-sap buf)))
|
||||||
(if timeout-ms
|
(if timeout-ms
|
||||||
(progn (sb-unix:unix-simple-poll fd :input timeout-ms)
|
(let ((poll-result (sb-unix:unix-simple-poll fd-stream :input timeout-ms)))
|
||||||
(let ((n (sb-unix:unix-read fd sap 1)))
|
(if poll-result
|
||||||
(if (= n 1) (aref buf 0) (values nil :eof))))
|
(let ((n (sb-unix:unix-read fd-stream sap 1)))
|
||||||
(let ((n (sb-unix:unix-read fd sap 1)))
|
(if (= n 1)
|
||||||
|
(aref buf 0)
|
||||||
|
;; EOF on fd — try opening /dev/tty
|
||||||
|
(let ((tty-fd (sb-unix:unix-open "/dev/tty" sb-unix:o_rdonly)))
|
||||||
|
(if (and tty-fd (>= tty-fd 0))
|
||||||
|
(let ((m (sb-unix:unix-read tty-fd sap 1)))
|
||||||
|
(sb-unix:unix-close tty-fd)
|
||||||
|
(if (= m 1) (aref buf 0) (values nil nil)))
|
||||||
|
(values nil nil)))))
|
||||||
|
(values nil nil)))
|
||||||
|
(let ((n (sb-unix:unix-read fd-stream sap 1)))
|
||||||
(if (= n 1) (aref buf 0) (values nil :eof))))))))
|
(if (= n 1) (aref buf 0) (values nil :eof))))))))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
||||||
@@ -627,22 +650,27 @@ to ~parse-csi-params~ for modifier extraction.
|
|||||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
|
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
|
||||||
(defun parse-csi-sequence ()
|
(defun parse-csi-sequence ()
|
||||||
(flet ((read-param (next-fn) (let ((acc nil))
|
(flet ((read-param (next-fn) (let ((acc nil))
|
||||||
(loop for b = (funcall next-fn)
|
(loop for b = (funcall next-fn)
|
||||||
do (if (and (>= b 48) (<= b 57))
|
do (if (and (>= b 48) (<= b 57))
|
||||||
(push (- b 48) acc)
|
(push (- b 48) acc)
|
||||||
(return (values (reverse acc) b)))))))
|
(return (values (reverse acc) b)))))))
|
||||||
(let* ((b2 (read-raw-byte)))
|
(let* ((b2 (read-raw-byte)))
|
||||||
(if (= b2 60) ;; < — SGR mouse marker
|
(if (= b2 60) ;; < — SGR mouse marker
|
||||||
(%parse-sgr-mouse)
|
(%parse-sgr-mouse)
|
||||||
(let* ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0))
|
(let* ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0))
|
||||||
(params (if (and (>= b2 48) (<= b2 57))
|
(parsed (if (and (>= b2 48) (<= b2 57))
|
||||||
(multiple-value-bind (p term) (read-param (lambda () (read-raw-byte)))
|
;; Digit branch: read params with their digits
|
||||||
(setf (fill-pointer extended) (length p))
|
(let ((r (multiple-value-list (read-param (lambda () (read-raw-byte))))))
|
||||||
(replace extended p)
|
(let ((p (first r)))
|
||||||
(values p term))
|
(setf (fill-pointer extended) (length p))
|
||||||
(progn (vector-push-extend b2 extended) (read-param (lambda () (read-raw-byte)))))))
|
(replace extended p))
|
||||||
(destructuring-bind (params terminator) params
|
r)
|
||||||
(parse-csi-params params terminator extended)))))))
|
;; Non-digit branch: b2 is a direct CSI terminator
|
||||||
|
(progn (vector-push-extend b2 extended)
|
||||||
|
(list nil b2)))))
|
||||||
|
(let ((params (first parsed))
|
||||||
|
(terminator (or (second parsed) 0)))
|
||||||
|
(parse-csi-params (or params '()) terminator extended)))))))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
||||||
** UTF-8 decoder
|
** UTF-8 decoder
|
||||||
@@ -1350,6 +1378,12 @@ This is the first block tangling to text-input.lisp, so it includes the
|
|||||||
:accessor text-input-max-length)
|
:accessor text-input-max-length)
|
||||||
(on-submit :initform nil :initarg :on-submit
|
(on-submit :initform nil :initarg :on-submit
|
||||||
:accessor text-input-on-submit)
|
:accessor text-input-on-submit)
|
||||||
|
(on-cancel :initform nil :initarg :on-cancel
|
||||||
|
:accessor text-input-on-cancel)
|
||||||
|
(on-tab :initform nil :initarg :on-tab
|
||||||
|
:accessor text-input-on-tab)
|
||||||
|
(on-history :initform nil :initarg :on-history
|
||||||
|
:accessor text-input-on-history)
|
||||||
(layout-node :initform (make-layout-node) :accessor text-input-layout-node)
|
(layout-node :initform (make-layout-node) :accessor text-input-layout-node)
|
||||||
(focusable :initform t :accessor text-input-focusable)))
|
(focusable :initform t :accessor text-input-focusable)))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
@@ -1366,13 +1400,17 @@ even if the caller passes nil. This eliminates a class of nil-pointer
|
|||||||
errors in string operations downstream.
|
errors in string operations downstream.
|
||||||
|
|
||||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
|
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
|
||||||
(defun make-text-input (&key value cursor placeholder max-length on-submit)
|
(defun make-text-input (&key value cursor placeholder max-length
|
||||||
|
on-submit on-cancel on-tab on-history)
|
||||||
(make-instance 'text-input
|
(make-instance 'text-input
|
||||||
:value (or value "")
|
:value (or value "")
|
||||||
:cursor (or cursor 0)
|
:cursor (or cursor 0)
|
||||||
:placeholder (or placeholder "")
|
:placeholder (or placeholder "")
|
||||||
:max-length max-length
|
:max-length max-length
|
||||||
:on-submit on-submit))
|
:on-submit on-submit
|
||||||
|
:on-cancel on-cancel
|
||||||
|
:on-tab on-tab
|
||||||
|
:on-history on-history))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
||||||
** Character insertion
|
** Character insertion
|
||||||
@@ -1559,10 +1597,37 @@ key bindings.
|
|||||||
(:end (text-input-move-end input))
|
(:end (text-input-move-end input))
|
||||||
(:backspace (text-input-backspace input))
|
(:backspace (text-input-backspace input))
|
||||||
(:delete (text-input-delete input))
|
(:delete (text-input-delete input))
|
||||||
(:enter (let ((cb (text-input-on-submit input))) (when cb (funcall cb (text-input-value input)))))
|
(:enter (let ((cb (text-input-on-submit input))) (when cb (funcall cb (text-input-value input)))))
|
||||||
(:tab nil) (:escape nil)
|
(:tab (let ((cb (text-input-on-tab input)))
|
||||||
(otherwise (let ((ch (code-char (key-event-code event))))
|
(when cb
|
||||||
(when (and ch (graphic-char-p ch)) (text-input-insert input ch))))))))
|
(multiple-value-bind (new-text new-pos)
|
||||||
|
(funcall cb (text-input-value input) (text-input-cursor input))
|
||||||
|
(when new-text
|
||||||
|
(setf (text-input-value input) new-text
|
||||||
|
(text-input-cursor input) (or new-pos (length new-text)))
|
||||||
|
(mark-dirty input))))))
|
||||||
|
(:escape (let ((cb (text-input-on-cancel input))) (when cb (funcall cb))))
|
||||||
|
(:up (let ((cb (text-input-on-history input)))
|
||||||
|
(when cb
|
||||||
|
(multiple-value-bind (new-text new-pos)
|
||||||
|
(funcall cb :up)
|
||||||
|
(when new-text
|
||||||
|
(setf (text-input-value input) new-text
|
||||||
|
(text-input-cursor input) (or new-pos (length new-text)))
|
||||||
|
(mark-dirty input))))))
|
||||||
|
(:down (let ((cb (text-input-on-history input)))
|
||||||
|
(when cb
|
||||||
|
(multiple-value-bind (new-text new-pos)
|
||||||
|
(funcall cb :down)
|
||||||
|
(when new-text
|
||||||
|
(setf (text-input-value input) new-text
|
||||||
|
(text-input-cursor input) (or new-pos (length new-text)))
|
||||||
|
(mark-dirty input))))))
|
||||||
|
(otherwise (let ((code (key-event-code event)))
|
||||||
|
(when code
|
||||||
|
(let ((ch (code-char code)))
|
||||||
|
(when (and ch (graphic-char-p ch))
|
||||||
|
(text-input-insert input ch))))))))))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
||||||
** Text input rendering
|
** Text input rendering
|
||||||
@@ -1700,7 +1765,7 @@ for users writing ~:ctrl+p~ in their keymaps.
|
|||||||
(let ((mod-str (subseq name 0 plus))
|
(let ((mod-str (subseq name 0 plus))
|
||||||
(key-str (subseq name (1+ plus))))
|
(key-str (subseq name (1+ plus))))
|
||||||
(and (eql (intern key-str :keyword)
|
(and (eql (intern key-str :keyword)
|
||||||
(key-event-key event))
|
(intern (string-upcase (symbol-name (key-event-key event))) :keyword))
|
||||||
(cond
|
(cond
|
||||||
((string= mod-str "CTRL") (key-event-ctrl event))
|
((string= mod-str "CTRL") (key-event-ctrl event))
|
||||||
((string= mod-str "ALT") (key-event-alt event))
|
((string= mod-str "ALT") (key-event-alt event))
|
||||||
|
|||||||
@@ -50,7 +50,8 @@ and the backend's ~*theme-colors*~ for SGR resolution.
|
|||||||
(:use :cl :cl-tty.backend)
|
(:use :cl :cl-tty.backend)
|
||||||
(:export
|
(:export
|
||||||
#:theme #:make-theme #:theme-mode
|
#:theme #:make-theme #:theme-mode
|
||||||
#:theme-color #:load-preset #:define-preset))
|
#:theme-color #:load-preset #:define-preset
|
||||||
|
#:save-theme #:load-theme))
|
||||||
(in-package :cl-tty.theme)
|
(in-package :cl-tty.theme)
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
||||||
@@ -395,5 +396,43 @@ contrast than default, designed for reduced eye strain.
|
|||||||
:markdown-link "#81A1C1" :markdown-quote "#8F9BB3"
|
:markdown-link "#81A1C1" :markdown-quote "#8F9BB3"
|
||||||
:syntax-keyword "#81A1C1" :syntax-function "#A3BE8C"
|
:syntax-keyword "#81A1C1" :syntax-function "#A3BE8C"
|
||||||
:syntax-string "#D08770" :syntax-number "#B48EAD"
|
:syntax-string "#D08770" :syntax-number "#B48EAD"
|
||||||
:syntax-comment "#8F9BB3" :syntax-type "#88C0D0"))
|
:syntax-comment "#8F9BB3" :syntax-type "#88C0D0"))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** Persistence
|
||||||
|
|
||||||
|
The theme system provides functions to save and restore a theme's role
|
||||||
|
map to and from a Lisp data file. The file format is an alist of
|
||||||
|
~(role . hex)~ pairs, written by ~prin1~ and read with ~read~.
|
||||||
|
|
||||||
|
*** defun save-theme
|
||||||
|
|
||||||
|
Serialises the theme's role hash table to a file. Each ~(role . hex)~
|
||||||
|
pair is written as a cons cell in an alist.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
|
||||||
|
(defun save-theme (theme path)
|
||||||
|
"Persist THEME's role map to file at PATH as an alist."
|
||||||
|
(ensure-directories-exist path)
|
||||||
|
(with-open-file (out path :direction :output :if-exists :supersede)
|
||||||
|
(let (alist)
|
||||||
|
(maphash (lambda (k v) (push (cons k v) alist)) (theme-roles theme))
|
||||||
|
(prin1 (nreverse alist) out))
|
||||||
|
t))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
*** defun load-theme
|
||||||
|
|
||||||
|
Restores a theme's role map from a file previously written by
|
||||||
|
~save-theme~. The file is an alist of ~(role . hex)~ pairs. If the
|
||||||
|
file does not exist, returns nil silently.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
|
||||||
|
(defun load-theme (theme path)
|
||||||
|
"Restore THEME's role map from file at PATH.
|
||||||
|
Returns T on success, nil if the file does not exist."
|
||||||
|
(when (probe-file path)
|
||||||
|
(with-open-file (in path :direction :input)
|
||||||
|
(dolist (pair (read in) t)
|
||||||
|
(setf (gethash (car pair) (theme-roles theme)) (cdr pair))))))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|||||||
Reference in New Issue
Block a user