Add editor

wip-duuqnd/editor/editor.asd

@@ -0,0 +1,8 @@
+;;;; editor.asd
+
+(asdf:defsystem #:editor
+  :version "0.0.1"
+  :serial t
+  :depends-on (#:user-side-compiler #:trivial-gray-streams)
+  :components ((:file "package")
+               (:file "editor")))

wip-duuqnd/editor/editor.lisp

@@ -0,0 +1,723 @@
+;;;; A cleanup pass, so often required.
+;;;; A cleanup pass, so rarely afforded.
+;;;; A cleanup pass, so very desired.
+;;;; A cleanup pass, this poem received.
+
+;;;; But not the code, that garbage is FIRST DRAFT quality. Wrap this sucker
+;;;; in a big ol' HANDLER-BIND because it *will* throw errors in real use.
+
+(in-package #:editor)
+
+(require '#:sb-posix)
+
+(defvar *eio*)
+
+(defclass hybrid-stream (fundamental-stream)
+  ((%input-stream :accessor input-stream :initarg :input-stream)
+   (%output-stream :accessor output-stream :initarg :output-stream)))
+
+(defmethod close ((stream hybrid-stream) &key abort)
+  (when (slot-boundp stream '%input-stream)
+    (close (input-stream stream) :abort abort))
+  (when (slot-boundp stream '%output-stream)
+    (close (output-stream stream) :abort abort)))
+
+(defmethod input-descriptor ((stream hybrid-stream))
+  (sb-posix:file-descriptor (input-stream stream)))
+
+(defmethod output-descriptor ((stream hybrid-stream))
+  (sb-posix:file-descriptor (output-stream stream)))
+
+(defmethod stream-write-byte ((stream hybrid-stream) integer)
+  (write-byte integer (output-stream stream)))
+
+(defmethod stream-write-char ((stream hybrid-stream) character)
+  (if (char= character #\Newline)
+      (terpri stream)
+      (let ((byte (char-code character)))
+        (when (not (typep character 'base-char))
+          (setf byte #.(char-code #\?)))
+        (stream-write-byte stream byte))))
+
+(defmethod stream-read-byte ((stream hybrid-stream))
+  (read-byte (input-stream stream)))
+
+(defmethod stream-read-char ((stream hybrid-stream))
+  (the base-char (code-char (stream-read-byte stream))))
+
+(defmethod stream-read-line ((stream hybrid-stream))
+  (warn "READ-LINE: Cancel is not yet implemented")
+  (loop :with buffer := (make-array 80 :element-type 'base-char
+                                       :adjustable t
+                                       :fill-pointer 0)
+        :for char := (read-char stream)
+        :until (or (char= char #\Return) (char= char #\Newline))
+        :do (vector-push char buffer)
+        :finally (return (copy-seq buffer))))
+
+(defmethod stream-write-string ((stream hybrid-stream) string &optional start end)
+  (loop :for index :from start :below end
+        :do (write-char (char string index) stream)))
+
+(defmethod stream-line-column ((stream hybrid-stream))
+  nil)
+
+(defmethod stream-terpri ((stream hybrid-stream))
+  (write-byte (char-code #\Return) stream)
+  (write-byte (char-code #\Newline) stream))
+
+(defmethod stream-fresh-line ((stream hybrid-stream))
+  (terpri stream)
+  t)
+
+(defmethod stream-force-output ((stream hybrid-stream))
+  (force-output (output-stream stream)))
+
+(defmethod stream-finish-output ((stream hybrid-stream))
+  (finish-output (output-stream stream)))
+
+
+
+(defun open-terminal (path)
+  (destructuring-bind (input-stream output-stream)
+      (loop :repeat 2
+            :collect (open path
+                           :direction :io
+                           :element-type '(unsigned-byte 8)
+                           :if-exists :overwrite))
+    (handler-case
+        (make-instance 'hybrid-stream :input-stream input-stream
+                                      :output-stream output-stream)
+      (error ()
+        (close input-stream)
+        (close output-stream)))))
+
+(defun close-terminal ()
+  (close (input-stream *eio*))
+  (close (output-stream *eio*)))
+
+(defun set-up-terminal ()
+  (let ((raw (make-instance 'sb-posix:termios))
+        (fd (input-descriptor *eio*)))
+    (flet
+        ((bit-number (bit-set)
+           (1- (the (integer 1) (integer-length bit-set)))))
+      (sb-posix:tcgetattr fd raw)
+      (loop :for bit :in (list sb-posix:ixon sb-posix:brkint sb-posix:istrip)
+            :do (setf (ldb (byte 1 (bit-number bit))
+                           (sb-posix:termios-iflag raw))
+                      0))
+      (loop :for bit :in (list sb-posix:echo sb-posix:icanon sb-posix:isig
+                               sb-posix:iexten)
+            :do (setf (ldb (byte 1 (bit-number bit))
+                           (sb-posix:termios-lflag raw))
+                      0))
+      (setf (ldb (byte 1 (bit-number sb-posix:opost))
+                 (sb-posix:termios-oflag raw))
+            0)
+      (sb-posix:tcsetattr fd sb-posix:tcsaflush raw))))
+
+
+
+(defun move-cursor (row col)
+  (write-byte #x1B *eio*)
+  (write-char #\[ *eio*)
+  (format *eio* "~D;~DH" row (1+ col))
+  (force-output *eio*))
+
+(defun clear-screen ()
+  (move-cursor 1 0)
+  (write-byte #x1B *eio*)
+  (write-char #\[ *eio*)
+  (write-char #\J *eio*)
+  (force-output *eio*))
+
+(defun clear-line ()
+  (write-char #\Return *eio*)
+  (write-byte #x1B *eio*)
+  (write-char #\[ *eio*)
+  (write-char #\K *eio*)
+  (force-output *eio*))
+
+(defun scroll-screen-down (&optional (amount 1))
+  (write-byte #x1B *eio*)
+  (write-char #\[ *eio*)
+  (format *eio* "~D" amount)
+  (write-char #\T *eio*))
+
+(defun scroll-screen-up (&optional (amount 1))
+  (write-byte #x1B *eio*)
+  (write-char #\[ *eio*)
+  (format *eio* "~D" amount)
+  (write-char #\S *eio*))
+
+(defparameter +screen-width+ 80)
+
+
+
+(defclass editor ()
+  ((%buffers :accessor buffers)
+   (%current-buffer :accessor current-buffer)
+   (%stream :accessor editor-stream)))
+
+(defparameter *terminal-path* "/dev/pts/0")
+
+(defun %make-editor (stream)
+  (let ((editor (make-instance 'editor)))
+    (setf (editor-stream editor)
+          stream
+          (buffers editor)
+          (list (make-instance 'buffer))
+          (current-buffer editor)
+          (first (buffers editor)))
+    (set-up-terminal)
+    editor))
+
+(defun make-editor ()
+  (let ((stream (open-terminal *terminal-path*)))
+    (handler-bind ((error (lambda (c)
+                            (close stream)
+                            (error c))))
+      (setf *eio* stream)
+      (setf *editor* (%make-editor stream)))))
+
+(defvar *editor*)
+
+(defmacro with-editor-accessors (editor (&key buffers current-buffer
+                                           current-line current-column
+                                           stream)
+                                 &body body)
+  `(with-accessors ,(loop :for (accessor name)
+                            :in `((buffers ,buffers)
+                                  (current-buffer ,current-buffer)
+                                  (editor-stream ,stream))
+                          :unless (null name)
+                            :collect (list name accessor))
+       ,editor
+     (with-accessors ,(loop :for (accessor name)
+                              :in `((cursor-line ,current-line)
+                                    (cursor-column ,current-column))
+                            :unless (null name)
+                              :collect (list name accessor))
+         (cursor (current-buffer ,editor))
+       ,@body)))
+
+
+
+(defclass cursor ()
+  ((%buffer :accessor buffer :initarg :buffer)
+   (%line :accessor cursor-line :initarg :line)
+   (%column :accessor cursor-column :initarg :column :initform 0)))
+
+(defmethod (setf cursor-line) :after (new-value (object cursor))
+  (setf (cursor-column object) (cursor-column object)))
+
+(defmethod (setf cursor-column) :around (new-value (object cursor))
+  (when (> new-value (line-length (cursor-line object)))
+    (setf new-value (line-length (cursor-line object))))
+  (call-next-method new-value object))
+
+;;; Shortcuts
+
+(defmethod cursor ((obj editor))
+  (cursor (current-buffer obj)))
+
+(defmethod cursor-line ((obj editor))
+  (cursor-line (cursor obj)))
+
+(defmethod cursor-column ((obj editor))
+  (cursor-column (cursor obj)))
+
+(defmethod cursor-go-to ((cursor cursor) line column)
+  (check-type line integer)
+  (setf (cursor-line cursor)
+        (loop :for line-obj := (first-line (buffer cursor))
+                :then (next-line line-obj)
+              :when (null line-obj)
+                :do (error "No such line number ~D" line)
+              :when (eql line (line-number line-obj))
+                :return line-obj))
+  (setf (cursor-column cursor) column))
+
+
+
+(defclass line ()
+  ((%line-number :accessor line-number :initarg :number :initform 1)
+   (%content :accessor line-content
+             :initform (make-array 80 :element-type 'base-char
+                                      :initial-element #\Null
+                                      :fill-pointer 0))
+   (%next-line :accessor next-line :initarg :next-line
+               :initform nil)
+   (%prev-line :accessor prev-line :initarg :prev-line
+               :initform nil)))
+
+(defmethod ensure-correct-line-number ((line line))
+  (cond ((null (prev-line line))
+         (setf (line-number line) 1))
+        (t
+         (setf (line-number line)
+               (1+ (line-number (prev-line line)))))))
+
+(defmethod set-line-text ((line line) text)
+  (setf (fill-pointer (line-content line))
+        (length text))
+  (replace (line-content line) text))
+
+(defmethod line-has-room-p ((line line))
+  (< (fill-pointer (line-content line)) (1- +screen-width+)))
+
+(defmethod line-length ((line line))
+  (length (line-content line)))
+
+(defmethod insert-character-into-line ((line line) column character)
+  (unless (line-has-room-p line)
+    (error "No room on line."))
+  (cond ((= column (fill-pointer (line-content line)))
+         (vector-push character (line-content line)))
+        (t
+         (let ((to-shove (subseq (line-content line)
+                                 column)))
+           (incf (fill-pointer (line-content line)))
+           (replace (line-content line) to-shove
+                    :start1 (1+ column))
+           (setf (char (line-content line) column) character)))))
+
+(defmethod delete-character-in-line ((line line) column)
+  (unless (< column (fill-pointer (line-content line)))
+    (error "Can't delete past the FILL-POINTER."))
+  (let ((to-shove (subseq (line-content line) (1+ column))))
+    (replace (line-content line) to-shove :start1 column)
+    (decf (fill-pointer (line-content line)))))
+
+(defmethod new-line-at ((line line) column)
+  (let ((new (make-instance 'line :prev-line line
+                                  :next-line (next-line line))))
+    (unless (null (next-line line))
+      (setf (prev-line (next-line line)) new))
+    (setf (next-line line) new)
+    (set-line-text new (subseq (line-content line) column))
+    (setf (fill-pointer (line-content line)) column)
+    new))
+
+(defmethod delete-line ((line line))
+  (when (and (null (next-line line))
+             (null (prev-line line)))
+    (error "Tried to delete the only line, ~A" line))
+  (setf (cursor-line (cursor *editor*))
+        (if (null (prev-line line))
+            (next-line line)
+            (prev-line line)))
+  (unless (null (next-line line))
+    (setf (prev-line (next-line line)) (prev-line line)))
+  (unless (null (prev-line line))
+    (setf (next-line (prev-line line)) (next-line line)))
+  (unless (null (next-line line))
+    (ensure-correct-line-number (next-line line))))
+
+(defmethod merge-lines ((left-line line) (right-line line))
+  (cond ((>= (+ (line-length left-line) (line-length right-line))
+             +screen-width+)
+         (feep))
+        (t
+         (let ((start (line-length left-line)))
+           (setf (fill-pointer (line-content left-line))
+                 (+ (line-length left-line) (line-length right-line)))
+           (replace (line-content left-line) (line-content right-line)
+                    :start1 start)
+           (delete-line right-line)
+           (redisplay-view-from-line (current-view *editor*) left-line)
+           (setf (cursor-line (cursor *editor*)) left-line
+                 (cursor-column (cursor *editor*)) start)
+           (update-buffer-cursor (current-buffer *editor*))))))
+
+(defmethod redisplay-line ((line line))
+  ;; TODO: save the cursor position
+  (with-editor-accessors *editor* (:current-line current
+                                   :current-buffer buffer)
+    (move-cursor (view-line-number (buffer-view buffer) line) 0)
+    (write-char #\Return *eio*)
+    (write-byte #x1B *eio*)
+    (write-char #\[ *eio*)
+    (write-char #\K *eio*)
+    (write-string (line-content line) *eio*)
+    (update-buffer-cursor buffer))
+  (force-output *eio*))
+
+(defun save-cursor ())
+
+(defun restore-cursor ())
+
+
+
+(defclass buffer ()
+  ((%first-line :accessor first-line)
+   (%cursor :accessor cursor)
+   (%view :accessor buffer-view)))
+
+(defmethod initialize-instance :after ((instance buffer) &rest initargs
+                                       &key &allow-other-keys)
+  (declare (ignore initargs))
+  (setf (first-line instance) (make-instance 'line)
+        (cursor instance) (make-instance 'cursor
+                                         :line (first-line instance)
+                                         :buffer instance)
+        (buffer-view instance) (make-instance 'buffer-view :buffer instance)
+        (top-line (buffer-view instance)) (first-line instance)))
+
+(defmethod buffer-string ((buffer buffer))
+  "Returns a string equivalent to BUFFER's contents."
+  (with-output-to-string (output)
+    (loop :for line := (first-line buffer) :then (next-line line)
+          :until (null line)
+          :do (write-string (line-content line) output)
+              (terpri output))))
+
+(defmethod update-buffer-cursor ((buffer buffer))
+  "Makes sure the screen cursor is the same as BUFFER's logical cursor.
+Additionally ensures correct line numbers on the way, as a bonus."
+  (loop :for line := (first-line buffer) :then (next-line line)
+        :until (null line)
+        :do (ensure-correct-line-number line))
+  (let ((line-number (view-line-number (buffer-view buffer)
+                                       (cursor-line (cursor buffer)))))
+    ;; the ugly (of many, one)
+    (when (null line-number)            ; line is off-screen
+      (if (and (not (null (bottom-line (buffer-view buffer))))
+               (eql (next-line (bottom-line (buffer-view buffer)))
+                    (cursor-line (cursor buffer))))
+          (setf (top-line (buffer-view buffer))
+                (next-line (top-line (buffer-view buffer)))
+                (bottom-line (buffer-view buffer)) nil)
+          (setf (top-line (buffer-view buffer)) (cursor-line (cursor buffer))
+                (bottom-line (buffer-view buffer)) nil))
+      (redisplay-view (buffer-view buffer))
+      (setf line-number (view-line-number (buffer-view buffer)
+                                          (cursor-line (cursor buffer)))))
+    (move-cursor line-number (cursor-column (cursor buffer)))))
+
+
+
+(defun status-line-string ()
+  (format nil "Line ~D, column ~D.~80T"
+          (line-number (cursor-line *editor*))
+          (cursor-column *editor*)))
+
+(defun redisplay-status-line ()
+  (move-cursor 24 0)
+  (write-byte #x1B *eio*)
+  (write-char #\[ *eio*)
+  (write-char #\7 *eio*)
+  (write-char #\m *eio*)
+  (write-string (status-line-string) *eio*)
+  (write-byte #x1B *eio*)
+  (write-char #\[ *eio*)
+  (write-char #\m *eio*)
+  (update-buffer-cursor (current-buffer *editor*)))
+
+
+
+(defclass buffer-view ()
+  ((%buffer :accessor buffer :initarg :buffer)
+   (%top-line :accessor top-line :initform nil)
+   (%bottom-line :accessor bottom-line :initform nil)
+   (%height :accessor height :initform 20)))
+
+(defmacro do-view-lines ((line local-line-number) view &body body)
+  `(loop :repeat (height ,view)
+         :for ,local-line-number :from 1
+         :for ,line := (top-line ,view) :then (next-line ,line)
+         :until (null ,line)
+         :do (ensure-correct-line-number ,line)
+         :do (progn
+               ,@body)))
+
+(defmacro do-whole-view ((line local-line-number) view &body body)
+  `(loop :repeat (height ,view)
+         :for ,local-line-number :from 1
+         :for ,line := (top-line ,view) :then (if (null ,line)
+                                                  nil
+                                                  (next-line ,line))
+         :when (typep ,line 'line)
+           :do (ensure-correct-line-number ,line)
+         :do (progn
+               ,@body)))
+
+(defmethod view-line-number ((view buffer-view) (line line))
+  (loop :for number :from 1
+        :repeat (height view)
+        :for view-line := (top-line view) :then (next-line view-line)
+        :until (null view-line)
+        :when (eql line view-line)
+          :return number))
+
+(defmethod redisplay-view ((view buffer-view))
+  (clear-screen)
+  (do-view-lines (line number) view
+    (redisplay-line line)
+    (setf (bottom-line view) line))
+  (update-buffer-cursor (buffer view)))
+
+(defmethod update-view-bottom ((view buffer-view))
+  (do-view-lines (line number) view
+    (setf (bottom-line view) line)))
+
+(defmethod redisplay-view-line ((view buffer-view) (line line))
+  (redisplay-line line))
+
+(defmethod redisplay-view-from-line ((view buffer-view) (from-line line))
+  (let ((startedp nil))
+    (do-whole-view (current-line number) view
+      (when (eql from-line current-line)
+        (setf startedp t))
+      (when startedp
+        (if (typep current-line 'line)
+            (redisplay-view-line view current-line)
+            (progn
+              (move-cursor number 0)
+              (clear-line)))))
+    (update-buffer-cursor (buffer view))))
+
+(defmethod scroll-view-down ((view buffer-view))
+  (scroll-screen-up 1)         ; view goes down, screen contents go up
+  (update-view-bottom view)
+  (setf (top-line view) (next-line (top-line view))
+        (bottom-line view) (next-line (bottom-line view)))
+  (unless (null (bottom-line view))
+    (redisplay-view-from-line view (bottom-line view)))
+  (redisplay-status-line))
+
+(defmethod scroll-view-up ((view buffer-view))
+  (scroll-screen-down 1) ; view goes up, screen contents go down
+  (update-view-bottom view)
+  (setf (top-line view)
+        (prev-line (top-line view))
+        (bottom-line view)
+        (prev-line (bottom-line view)))
+  (redisplay-line (top-line view))
+  (redisplay-status-line))
+
+(defmethod current-view ((obj editor))
+  (buffer-view (current-buffer obj)))
+
+
+
+(defun feep ()
+  (write-char #\Bel *eio*)
+  (force-output *eio*))
+
+(defun insert-char (char)
+  (with-editor-accessors *editor* (:current-column column
+                                   :current-line line)
+    (if (line-has-room-p line)
+        (progn
+          (insert-character-into-line line column char)
+          (incf column))
+        (feep))
+    (redisplay-line line)))
+
+(defun com-forward-delete ()
+  ;; TODO: Check for end of line
+  (with-editor-accessors *editor* (:current-column column
+                                   :current-line line)
+    (delete-character-in-line line column)))
+
+(defun com-backward-delete ()
+  (with-editor-accessors *editor* (:current-column column
+                                   :current-line line)
+    (cond ((and (zerop column) (null (prev-line line)))
+           (feep))
+          ((zerop column)
+           (merge-lines (prev-line line) line))
+          (t
+           (delete-character-in-line line (1- column))
+           (decf column)
+           (redisplay-line line)))))
+
+(defun com-newline ()
+  (with-editor-accessors *editor* (:current-column column
+                                   :current-line line)
+    (ensure-correct-line-number (new-line-at line column))
+    (redisplay-view-from-line (current-view *editor*) line)
+    (com-next-line)
+    (com-beginning-of-line)
+    (redisplay-line line)))
+
+(defun com-beginning-of-line ()
+  (with-editor-accessors *editor* (:current-column column
+                                   :current-buffer buffer)
+    (setf column 0)
+    (update-buffer-cursor buffer)))
+
+(defun com-end-of-line ()
+  (with-editor-accessors *editor* (:current-column column
+                                   :current-line line
+                                   :current-buffer buffer)
+    (setf column (line-length line))
+    (update-buffer-cursor buffer)))
+
+(defun com-previous-line ()
+  (with-editor-accessors *editor* (:current-line line
+                                   :current-buffer buffer)
+    (cond ((null (prev-line line))
+           (feep))
+          (t
+           (setf line (prev-line line))
+           (update-buffer-cursor buffer)))))
+
+(defun com-next-line ()
+  (with-editor-accessors *editor* (:current-line line
+                                   :current-buffer buffer)
+    (cond ((null (next-line line))
+           (feep))
+          (t
+           (setf line (next-line line))
+           (update-buffer-cursor buffer)))))
+
+(defun com-forward-char ()
+  (with-editor-accessors *editor* (:current-column column
+                                   :current-line line
+                                   :current-buffer buffer)
+    (cond ((> (1+ column)
+              (line-length line))
+           (if (null (next-line line))
+               (feep)
+               (progn
+                 (com-beginning-of-line)
+                 (com-next-line))))
+          (t
+           (incf column)
+           (update-buffer-cursor buffer)))))
+
+(defun com-backward-char ()
+  (with-editor-accessors *editor* (:current-column column
+                                   :current-line line
+                                   :current-buffer buffer)
+    (decf column)
+    (when (< column 0)
+      (if (null (prev-line line))
+          (progn
+            (incf column)
+            (feep))
+          (progn
+            (com-previous-line)
+            (com-end-of-line))))
+    (update-buffer-cursor buffer)))
+
+(defun com-new-buffer ()
+  (setf (current-buffer *editor*)
+        (make-instance 'buffer))
+  (push (current-buffer *editor*) (buffers *editor*))
+  (redisplay-view (buffer-view (current-buffer *editor*))))
+
+(defun com-refresh-screen ()
+  (redisplay-view (buffer-view (current-buffer *editor*))))
+
+
+
+(defun compile-fail-prompt (text line col)
+  (clear-screen)
+  (move-cursor 1 0)
+  (format *eio* "~A~%~%RET: Go there.~%Anything else: Ignore." text)
+  (force-output *eio*)
+  (let ((key (get-input-sequence)))
+    (if (equal '(:C . #\j) key)
+        (cursor-go-to (cursor *editor*) line col)
+        (format t "~A~%" key)))
+  (clear-screen)
+  (redisplay-view (current-view *editor*)))
+
+(defun com-compile-buffer ()
+  (let ((bytes
+          (handler-case
+              (usc:compile-string-to-bytes
+               (buffer-string (current-buffer *editor*)))
+            (usc:usc-error (c)
+              (let ((source (cdr (usc:source c))))
+                (compile-fail-prompt c (car source) (cdr source)))))))))
+
+
+
+(defun ctrl (key)
+  (when (numberp key)
+    (setf key (code-char (+ (1- (char-code #\A)) key))))
+  (when (characterp key)
+    (setf key (char-downcase key)))
+  (cons :c key))
+
+(defparameter *csi-sequences*
+  '(((#\1 #\7 #\~) :f6)
+    ((#\1 #\8 #\~) :f7)
+    ((#\1 #\9 #\~) :f8)
+    ((#\2 #\0 #\~) :f9)
+    ((#\2 #\1 #\~) :f10)
+    ((#\A) :up)
+    ((#\B) :down)
+    ((#\C) :right)
+    ((#\D) :left)))
+
+(defun csi-handler ()
+  (loop :for buffer := '() :then (append buffer (list (read-char *eio*)))
+        :for found := (assoc buffer *csi-sequences* :test #'equalp)
+        :when (or found (not (zerop (some
+                                     (lambda (c)
+                                       (search buffer (car c)))
+                                     *csi-sequences*))))
+          :return (cadr found)))
+
+(defun esc (key)
+  (when (numberp key)
+    (setf key (code-char key)))
+  (when (char= key #\[)
+    (let ((next (csi-handler)))
+      (setf key next)))
+  (if (keywordp key)
+      key
+      (cons :m key)))
+
+(defparameter *key-command-mappings*
+  '(((:c . #\a) com-beginning-of-line)
+    ((:c . #\e) com-end-of-line)
+
+    (:f6 com-compile-buffer)
+    (:up com-previous-line)
+    (:down com-next-line)
+    (:right com-forward-char)
+    (:left com-backward-char)
+    (#\Del com-backward-delete)
+    ((:c . #\d) com-forward-delete)
+    ((:c . #\j) com-newline)
+    ((:c . #\n) com-new-buffer)
+    ((:c . #\l) com-refresh-screen)))
+
+(defun key-command-dispatch (key)
+  (when (numberp key)
+    (setf key (code-char key)))
+  (when (characterp key)
+    (setf key (char-downcase key)))
+  (let ((mapping (assoc key *key-command-mappings* :test #'equalp)))
+    (if (null mapping)
+        (format *eio* "Key ~A is unbound.~%" key)
+        (funcall (cadr mapping)))
+    (force-output *eio*)))
+
+(defun get-input-sequence ()
+  (let ((first-byte (read-byte *eio*)))
+    (cond ((< #x1F first-byte #x7F)
+           (code-char first-byte))
+          ((<= 1 first-byte 26)
+           (ctrl first-byte))
+          ((= first-byte #x1B)
+           (esc (read-byte *eio*)))
+          (t first-byte))))
+
+(defun editor-take-command ()
+  (let ((input (get-input-sequence)))
+    (if (characterp input)
+        (insert-char input)
+        (key-command-dispatch input)))
+  (redisplay-status-line)
+  (force-output *eio*))
+
+(defun editor-loop ()
+  (loop (editor-take-command)))

wip-duuqnd/editor/package.lisp

@@ -0,0 +1,4 @@
+;;;; package.lisp
+
+(defpackage #:editor
+  (:use #:cl #:trivial-gray-streams))