path: root/catbird/line-editor.scm

(define-module (catbird line-editor)
  #:use-module (catbird mode)
  #:use-module (catbird node)
  #:use-module (catbird node-2d)
  #:use-module (catbird observer)
  #:use-module (catbird region)
  #:use-module (catbird ring-buffer)
  #:use-module (catbird scene)
  #:use-module (chickadee)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics text)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:export (<line-editor>
            <line-edit-mode>
            backward-char
            backward-delete-char
            forward-delete-char
            backward-history
            beginning-of-line
            clear-line
            end-of-line
            forward-char
            forward-history
            get-line
            history-enabled?
            insert-char
            invert-color
            kill-line
            overwrite
            prompt
            save-to-history)
  #:re-export (color
               font))

;; TODO: Matching paren/quote highlighting.
(define-class <line-editor> (<node-2d>)
  (chars-before #:accessor chars-before #:init-value '())
  (chars-after #:accessor chars-after #:init-value '())
  (cached-line #:accessor cached-line #:init-value #f)
  (prompt #:accessor prompt #:init-keyword #:prompt #:init-value ""
          #:observe? #t)
  ;; TODO: Allow customizable history length.
  (history #:accessor history #:init-form (make-ring-buffer 128))
  (history-enabled? #:accessor history-enabled?
                    #:init-keyword #:history-enabled? #:init-value #t)
  (history-index #:accessor history-index #:init-value 0)
  (font #:accessor font #:init-keyword #:font #:init-thunk default-font
        #:asset? #t)
  (color #:accessor color #:init-keyword #:color #:init-value white)
  (invert-color #:accessor invert-color #:init-keyword #:invert-color
                #:init-value black)
  (accepting-input? #:accessor accepting-input? #:init-value #t))

(define-method (on-change (editor <line-editor>) slot old new)
  (update-visual editor))

(define-method (on-boot (editor <line-editor>))
  (attach-to editor
             (make <label>
               #:name 'prompt
               #:font (font editor)
               #:text (prompt editor)
               #:color (color editor))
             (make <label>
               #:name 'before-cursor
               #:rank 1
               #:font (font editor)
               #:color (color editor))
             (make <label>
               #:name 'on-cursor
               #:rank 1
               #:font (font editor))
             (make <label>
               #:name 'after-cursor
               #:rank 1
               #:font (font editor)
               #:color (color editor))
             (make <canvas>
               #:name 'cursor
               #:painter
               (with-style ((fill-color (color editor)))
                 (fill
                  (rectangle (vec2 0.0 0.0)
                             (font-line-width (font editor) "_")
                             (font-line-height (font editor)))))))
  (discard-next-char editor)
  (update-visual editor))

;; Whenever a command key sequence is pressed while the line editor is
;; active we have to stop accepting text input for one tick.
;; Otherwise, an errant character shows up.  For example, if the user
;; presses alt+p, and that is bound to (backward-history editor 1),
;; the 'p' character shows up at the end of the line.  This is due to
;; the fact that SDL generates a key event *and* an input event for
;; the same key press.
(define-method (discard-next-char (editor <line-editor>))
  (run-script editor
    (set! (accepting-input? editor) #f)
    (sleep (current-timestep))
    (set! (accepting-input? editor) #t)))

(define-method (update-visual (editor <line-editor>))
  (let* ((lprompt (& editor prompt))
         (cursor (& editor cursor))
         (before (& editor before-cursor))
         (on (& editor on-cursor))
         (after (& editor after-cursor)))
    (set! (cached-line editor) #f)
    ;; Stop cursor blink.  The cursor should only blink when the user
    ;; is idle.
    (stop-scripts cursor)
    ;; Ensure the cursor is visible in case we stopped the script
    ;; during a time when it was hidden.
    (show cursor)
    ;; Put the proper text in the proper labels
    (set! (text lprompt) (prompt editor))
    (set! (text before)
          (list->string (reverse (chars-before editor))))
    (set! (text on)
          (match (chars-after editor)
            (() "")
            ((c . _)
             (string c))))
    (set! (text after)
          (match (chars-after editor)
            (() "")
            ((_ . chars)
             (list->string chars))))
    ;; Line everything up.
    (place-right lprompt before)
    (place-right before on)
    (place-right on after)
    (align-left on cursor)
    ;; Adjust size
    (set! (width editor)
          (+ (width lprompt) (width before) (width on) (width after)))
    (set! (height editor) (height cursor))
    ;; Resume blinking cursor after a short idle timeout.
    (run-script cursor
      (forever
       (set! (color on) (invert-color editor))
       (sleep 0.5)
       (hide cursor)
       (set! (color on) (color editor))
       (sleep 0.5)
       (show cursor)))))

(define-method (get-line (editor <line-editor>))
  (or (cached-line editor)
      (let ((line (list->string
                   (append (reverse (chars-before editor))
                           (chars-after editor)))))
        (set! (cached-line editor) line)
        line)))

(define-method (overwrite (editor <line-editor>) str)
  (set! (chars-before editor) (reverse (string->list str)))
  (set! (chars-after editor) '())
  (update-visual editor))

(define-method (clear-line (editor <line-editor>))
  (discard-next-char editor)
  (overwrite editor "")
  (newest-history editor))

(define-method (insert-char (editor <line-editor>) char)
  (when (accepting-input? editor)
    (set! (chars-before editor) (cons char (chars-before editor)))
    (update-visual editor)))

(define-method (backward-delete-char (editor <line-editor>) n)
  (unless (<= n 0)
    (set! (chars-before editor)
          (drop (chars-before editor)
                (min n (length (chars-before editor))))))
  (discard-next-char editor)
  (update-visual editor))

(define-method (forward-delete-char (editor <line-editor>) n)
  (unless (<= n 0)
    (set! (chars-after editor)
          (drop (chars-after editor)
                (min n (length (chars-after editor))))))
  (discard-next-char editor)
  (update-visual editor))

(define-method (kill-line (editor <line-editor>))
  (forward-delete-char editor (length (chars-after editor))))

(define-method (backward-char (editor <line-editor>) n)
  (let loop ((n n)
             (before (chars-before editor))
             (after (chars-after editor)))
    (if (or (<= n 0) (null? before))
        (begin
          (set! (chars-before editor) before)
          (set! (chars-after editor) after))
        (loop (- n 1)
              (cdr before)
              (cons (car before) after))))
  (discard-next-char editor)
  (update-visual editor))

(define-method (forward-char (editor <line-editor>) n)
  (let loop ((n n)
             (before (chars-before editor))
             (after (chars-after editor)))
    (if (or (<= n 0) (null? after))
        (begin
          (set! (chars-before editor) before)
          (set! (chars-after editor) after))
        (loop (- n 1)
              (cons (car after) before)
              (cdr after))))
  (discard-next-char editor)
  (update-visual editor))

(define-method (beginning-of-line (editor <line-editor>))
  (backward-char editor (length (chars-before editor))))

(define-method (end-of-line (editor <line-editor>))
  (forward-char editor (length (chars-after editor))))

(define-method (save-to-history (editor <line-editor>))
  (ring-buffer-put! (history editor) (get-line editor)))

(define-method (history-ref (editor <line-editor>) i)
  (ring-buffer-ref (history editor) i))

(define-method (go-to-history (editor <line-editor>) i)
  (when (and (history-enabled? editor)
             (>= i 0)
             (< i (ring-buffer-length (history editor))))
    (set! (history-index editor) i)
    (overwrite editor (history-ref editor i))))

(define-method (backward-history (editor <line-editor>) n)
  (discard-next-char editor)
  (go-to-history editor (max (- (history-index editor) n) 0)))

(define-method (forward-history (editor <line-editor>) n)
  (discard-next-char editor)
  (go-to-history editor
                 (min (+ (history-index editor) n)
                      (- (ring-buffer-length (history editor)) 1))))

(define-method (newest-history (editor <line-editor>))
  (set! (history-index editor) (ring-buffer-length (history editor))))


;;;
;;; Line editing minor mode
;;;

(define-class <line-edit-mode> (<minor-mode>)
  (editor #:accessor editor #:init-keyword #:editor))

(define-method (insert-text (mode <line-edit-mode>) new-text)
  (let ((e (editor mode)))
    (string-for-each (lambda (char)
                       (insert-char e char))
                     new-text)))

(define-method (backward-delete-char (mode <line-edit-mode>))
  (backward-delete-char (editor mode) 1))

(define-method (forward-delete-char (mode <line-edit-mode>))
  (forward-delete-char (editor mode) 1))

(define-method (backward-char (mode <line-edit-mode>))
  (backward-char (editor mode) 1))

(define-method (forward-char (mode <line-edit-mode>))
  (forward-char (editor mode) 1))

(define-method (beginning-of-line (mode <line-edit-mode>))
  (beginning-of-line (editor mode)))

(define-method (end-of-line (mode <line-edit-mode>))
  (end-of-line (editor mode)))

(define-method (backward-history (mode <line-edit-mode>))
  (backward-history (editor mode) 1))

(define-method (forward-history (mode <line-edit-mode>))
  (forward-history (editor mode) 1))

(define-method (kill-line (mode <line-edit-mode>))
  (kill-line (editor mode)))

(bind-input <line-edit-mode> (key-press 'backspace) backward-delete-char)
(bind-input <line-edit-mode> (key-press 'delete) forward-delete-char)
(bind-input <line-edit-mode> (key-press 'd '(ctrl)) forward-delete-char)
(bind-input <line-edit-mode> (key-press 'left) backward-char)
(bind-input <line-edit-mode> (key-press 'b '(ctrl)) backward-char)
(bind-input <line-edit-mode> (key-press 'right) forward-char)
(bind-input <line-edit-mode> (key-press 'f '(ctrl)) forward-char)
(bind-input <line-edit-mode> (key-press 'home) beginning-of-line)
(bind-input <line-edit-mode> (key-press 'a '(ctrl)) beginning-of-line)
(bind-input <line-edit-mode> (key-press 'end) end-of-line)
(bind-input <line-edit-mode> (key-press 'e '(ctrl)) end-of-line)
(bind-input <line-edit-mode> (key-press 'up) backward-history)
(bind-input <line-edit-mode> (key-press 'p '(alt)) backward-history)
(bind-input <line-edit-mode> (key-press 'down) forward-history)
(bind-input <line-edit-mode> (key-press 'n '(alt)) forward-history)
(bind-input <line-edit-mode> (key-press 'k '(ctrl)) kill-line)
(bind-input <line-edit-mode> (text-input) insert-text)