diff --git a/wip-duuqnd/editor/editor.asd b/wip-duuqnd/editor/editor.asd new file mode 100644 index 0000000..999c9d4 --- /dev/null +++ b/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"))) diff --git a/wip-duuqnd/editor/editor.lisp b/wip-duuqnd/editor/editor.lisp new file mode 100644 index 0000000..5fe0985 --- /dev/null +++ b/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))) diff --git a/wip-duuqnd/editor/package.lisp b/wip-duuqnd/editor/package.lisp new file mode 100644 index 0000000..ad46bb0 --- /dev/null +++ b/wip-duuqnd/editor/package.lisp @@ -0,0 +1,4 @@ +;;;; package.lisp + +(defpackage #:editor + (:use #:cl #:trivial-gray-streams))