723 lines
24 KiB
Common Lisp
723 lines
24 KiB
Common Lisp
;;;; 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)))
|