tui: wrap long input at right edge so it doesn't disappear under the sidebar
ober
5ae3a81d101436d8bc301d603ccda6b28d2f1664
--- a/src/jcode/ui/tui-input.ss +++ b/src/jcode/ui/tui-input.ss @@ -11,7 +11,7 @@ input-state-stash-set! input-handle-key! input-submit! input-clear! - input-lines input-cursor-row input-cursor-col + input-lines render-input! render-completion! *slash-commands*) @@ -254,57 +254,108 @@ ;; ---- Query ---- (def (input-lines inp) - "Split input text into lines." + "Split input text into logical lines (by \\n)." (string-split (input-state-text inp) #\newline)) -(def (input-cursor-row inp) - "Which line the cursor is on (0-based)." - (let ((text (input-state-text inp)) - (pos (input-state-cursor-pos inp))) - (let loop ((i 0) (row 0)) - (cond - ((>= i pos) row) - ((char=? (string-ref text i) #\newline) (loop (+ i 1) (+ row 1))) - (#t (loop (+ i 1) row)))))) - -(def (input-cursor-col inp) - "Column within current line (0-based)." - (let ((text (input-state-text inp)) - (pos (input-state-cursor-pos inp))) - (let loop ((i (- pos 1)) (col 0)) - (cond - ((< i 0) col) - ((char=? (string-ref text i) #\newline) col) - (#t (loop (- i 1) (+ col 1))))))) +;; ---- Visual layout (with auto-wrap) ---- +;; Long lines wrap at the input area's right edge so typed text never +;; bleeds into the sidebar column range (where it was being clobbered on +;; the next redraw). Row 0 is indented by the prompt; continuation rows +;; by 2 cols, matching the existing newline-continuation style. + +(def (find-newline-from text start end) + (let loop ((i start)) + (cond + ((>= i end) #f) + ((char=? (string-ref text i) #\newline) i) + (#t (loop (+ i 1)))))) + +(def (input-visual-rows text width prompt-len) + "Compute visual rows after wrapping. Each row is (start-pos col-offset row-text). + When a logical line is wider than the available width, it splits at character + boundaries. A trailing empty row is emitted after a consumed newline or after + a width-wrap that exactly filled the last row, so the cursor at end-of-text + has a row to land on." + (let ((text-len (string-length text))) + (let loop ((i 0) (row-idx 0) (acc '()) (need-trailing? #f)) + (let* ((col (if (= row-idx 0) prompt-len 2)) + (avail (max 1 (- width col)))) + (cond + ((and (= row-idx 0) (= text-len 0)) + (list (list 0 col ""))) + ((and (>= i text-len) need-trailing?) + (reverse (cons (list i col "") acc))) + ((>= i text-len) + (reverse acc)) + (else + (let ((nl-pos (find-newline-from text i text-len)) + (max-end (+ i avail))) + (cond + ((and nl-pos (<= nl-pos max-end)) + (loop (+ nl-pos 1) (+ row-idx 1) + (cons (list i col (substring text i nl-pos)) acc) + #t)) + (#t + (let* ((end (min max-end text-len)) + (filled-to-eol? (and (= (- end i) avail) + (= end text-len)))) + (loop end (+ row-idx 1) + (cons (list i col (substring text i end)) acc) + filled-to-eol?))))))))))) + +(def (cursor-visual-pos rows pos) + "Map a character offset into (values row-idx screen-col) within visual rows." + (let loop ((rest rows) (idx 0)) + (cond + ((null? rest) (values 0 0)) + ((null? (cdr rest)) + (let ((row (car rest))) + (values idx (+ (cadr row) (- pos (car row)))))) + (else + (let* ((row (car rest)) + (next-start (car (cadr rest))) + (start (car row)) + (col (cadr row))) + (if (< pos next-start) + (values idx (+ col (- pos start))) + (loop (cdr rest) (+ idx 1)))))))) + +;; Cap on visible input rows. When wrapped content exceeds this, we scroll +;; vertically so the cursor row stays in view. +(def *input-max-visible-rows* 8) ;; ---- Rendering ---- (def (render-input! inp x y width prompt-text) "Render the input prompt at (x, y). Returns number of rows used." - (let* ((lines (input-lines inp)) - (nlines (length lines)) - (pfg (face-fg-attr 'input-prompt)) + (let* ((pfg (face-fg-attr 'input-prompt)) (pbg (face-bg-attr 'input-prompt)) (tfg (face-fg-attr 'input-text)) (tbg (face-bg-attr 'input-text)) - (prompt-len (string-length prompt-text))) - ;; Render first line with prompt - (clear-row! x y width tbg) - (tb-print! x y pfg pbg prompt-text) - (when (pair? lines) - (tb-print! (+ x prompt-len) y tfg tbg (car lines))) - ;; Render continuation lines - (let loop ((rest (if (pair? lines) (cdr lines) '())) (row (+ y 1))) - (when (pair? rest) - (clear-row! x row width tbg) - (tb-print! (+ x 2) row tfg tbg (car rest)) - (loop (cdr rest) (+ row 1)))) - ;; Position cursor - (let ((crow (input-cursor-row inp)) - (ccol (input-cursor-col inp))) - (tb-set-cursor! (+ x (if (= crow 0) (+ prompt-len ccol) (+ 2 ccol))) - (+ y crow))) - (max 1 nlines))) + (prompt-len (string-length prompt-text)) + (rows (input-visual-rows (input-state-text inp) width prompt-len)) + (n-rows (length rows)) + (visible (min n-rows *input-max-visible-rows*))) + (let-values (((crow ccol) (cursor-visual-pos rows (input-state-cursor-pos inp)))) + (let ((scroll (max 0 (- crow (- visible 1))))) + (let loop ((rs rows) (skip scroll) (yi 0)) + (cond + ((or (null? rs) (>= yi visible)) (void)) + ((> skip 0) (loop (cdr rs) (- skip 1) yi)) + (#t + (let* ((r (car rs)) + (col-off (cadr r)) + (row-text (caddr r)) + (row-y (+ y yi)) + (show-prompt? (and (= scroll 0) (= yi 0)))) + (clear-row! x row-y width tbg) + (when show-prompt? + (tb-print! x row-y pfg pbg prompt-text)) + (tb-print! (+ x col-off) row-y tfg tbg row-text) + (loop (cdr rs) 0 (+ yi 1)))))) + (tb-set-cursor! (+ x (min ccol (max 0 (- width 1)))) + (+ y (- crow scroll))))) + (max 1 visible))) (def (render-completion! inp x y width) "Render completion overlay above the input area."