;;;; 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)))