417 lines
16 KiB
Common Lisp
417 lines
16 KiB
Common Lisp
(uiop:define-package :sextant/models/commands
|
||
(:use :cl :eql :org :options :qml-lisp :s-base64 :alexandria
|
||
:sextant/models/org-model
|
||
:sextant/models/cursor)
|
||
(:import-from :inferior-shell #:run)
|
||
(:export #:modify-text
|
||
#:join-node
|
||
#:split-node
|
||
#:undo
|
||
#:can-undo-p
|
||
#:redo
|
||
#:can-redo-p
|
||
#:save-file
|
||
#:can-save-p
|
||
#:load-commands
|
||
#:save-commands
|
||
#:initialize-commands))
|
||
(in-package :sextant/models/commands)
|
||
|
||
(defvar *initial-state* nil)
|
||
(defvar *current-state* nil)
|
||
(defvar *saved-state* nil)
|
||
(defvar *saved-hash* "")
|
||
|
||
|
||
|
||
(defclass command ()
|
||
((index :initarg :index
|
||
:type integer
|
||
:accessor index-of
|
||
:initform 0
|
||
:documentation "The index of the related node.")
|
||
(previous :initarg :previous
|
||
:type command
|
||
:accessor previous-of
|
||
:initform nil
|
||
:documentation "A link to the previous command in the list.")
|
||
(next :initarg :next
|
||
:type command
|
||
:accessor next-of
|
||
:initform nil
|
||
:documentation "A link to the next command in the list.")))
|
||
|
||
(defclass command-initial-state (command)
|
||
())
|
||
|
||
(defclass command-modify-text (command)
|
||
((before-text :initarg :before-text
|
||
:type string
|
||
:accessor before-text-of
|
||
:initform ""
|
||
:documentation "The text node had before this command.")
|
||
(after-text :initarg :after-text
|
||
:type string
|
||
:accessor after-text-of
|
||
:initform ""
|
||
:documentation "The text this command needs to apply.")))
|
||
|
||
(defclass command-join/split-node (command)
|
||
((previous-text :initarg :previous-text
|
||
:type string
|
||
:accessor previous-text-of
|
||
:initform ""
|
||
:documentation "The text of the previous node.")
|
||
(previous-eol :initarg :previous-eol
|
||
:type string
|
||
:accessor previous-eol-of
|
||
:initform ""
|
||
:documentation "The line ending of the previous node.")
|
||
(next-text :initarg :next-text
|
||
:type string
|
||
:accessor next-text-of
|
||
:initform ""
|
||
:documentation "The text of the next node.")
|
||
(next-eol :initarg :next-eol
|
||
:type string
|
||
:accessor next-eol-of
|
||
:initform ""
|
||
:documentation "The line ending of the next node.")))
|
||
|
||
(defclass command-join-node (command-join/split-node)
|
||
())
|
||
|
||
(defclass command-split-node (command-join/split-node)
|
||
())
|
||
|
||
|
||
|
||
(defun do-modify-text (index new-text update-ui-p)
|
||
(setf (raw-text-of (goto-index index)) new-text)
|
||
(when update-ui-p
|
||
(reparse-node index)))
|
||
|
||
(defun do-join-node (command update-ui-p)
|
||
(let* ((node (goto-index (index-of command)))
|
||
(next (next-of node))
|
||
(next-next (next-of next)))
|
||
(setf (raw-text-of node) (concatenate 'string (previous-text-of command) (next-text-of command))
|
||
(line-ending-of node) (next-eol-of command))
|
||
(flet ((relink-nodes (n nn)
|
||
(setf (next-of n) nn)
|
||
(when nn (setf (previous-of nn) n))))
|
||
(if update-ui-p
|
||
(progn
|
||
(removing-rows ((1+ (index-of command)))
|
||
(relink-nodes node next-next))
|
||
(reparse-node (index-of command))
|
||
(qjs |focusIndex| "orgDocument" (current-visual-index) t (length (previous-text-of command))))
|
||
(progn
|
||
(relink-nodes node next-next)
|
||
(dec-nodes-count))))))
|
||
|
||
(defun do-split-node (command update-ui-p)
|
||
(let* ((node (goto-index (index-of command)))
|
||
(next (next-of node))
|
||
(new-node (make-org-line (next-text-of command) (next-eol-of command))))
|
||
(setf (raw-text-of node) (previous-text-of command)
|
||
(line-ending-of node) (previous-eol-of command))
|
||
(flet ((relink-nodes (n nn new)
|
||
(setf (next-of n) new
|
||
(previous-of new) n)
|
||
(when nn
|
||
(setf (previous-of nn) new
|
||
(next-of new) nn))))
|
||
(if update-ui-p
|
||
(progn
|
||
(inserting-rows ((1+ (index-of command)))
|
||
(relink-nodes node next new-node))
|
||
(reparse-node (index-of command))
|
||
(reparse-node (1+ (index-of command))))
|
||
(progn
|
||
(relink-nodes node next new-node)
|
||
(inc-visual-nodes-count))))))
|
||
|
||
|
||
|
||
(defgeneric apply-command (command update-ui-p))
|
||
|
||
(defmethod apply-command ((command command-modify-text) update-ui-p)
|
||
(do-modify-text (index-of command) (after-text-of command) update-ui-p))
|
||
|
||
(defmethod apply-command ((command command-join-node) update-ui-p)
|
||
(do-join-node command update-ui-p))
|
||
|
||
(defmethod apply-command ((command command-split-node) update-ui-p)
|
||
(do-split-node command update-ui-p))
|
||
|
||
|
||
|
||
(defgeneric unapply-command (command update-ui-p))
|
||
|
||
(defmethod unapply-command ((command command-modify-text) update-ui-p)
|
||
(do-modify-text (index-of command) (before-text-of command) update-ui-p))
|
||
|
||
(defmethod unapply-command ((command command-join-node) update-ui-p)
|
||
(do-split-node command update-ui-p))
|
||
|
||
(defmethod unapply-command ((command command-split-node) update-ui-p)
|
||
(do-join-node command update-ui-p))
|
||
|
||
|
||
|
||
(defgeneric serialize-command (command stream))
|
||
|
||
(defmethod serialize-command :around ((command command) stream)
|
||
(fresh-line stream)
|
||
(princ "(" stream)
|
||
(princ (type-of command) stream)
|
||
(princ " :index " stream)
|
||
(princ (index-of command) stream)
|
||
(call-next-method)
|
||
(princ ")" stream))
|
||
|
||
(defmethod serialize-command ((command command-initial-state) stream))
|
||
|
||
(defmethod serialize-command ((command command-modify-text) stream)
|
||
(with-slots (before-text after-text) command
|
||
(princ " :before-text " stream)
|
||
(prin1 before-text stream)
|
||
(princ " :after-text " stream)
|
||
(prin1 after-text stream)))
|
||
|
||
(defmethod serialize-command ((command command-join/split-node) stream)
|
||
(with-slots (previous-text previous-eol next-text next-eol) command
|
||
(princ " :previous-text " stream)
|
||
(prin1 previous-text stream)
|
||
(princ " :previous-eol " stream)
|
||
(prin1 previous-eol stream)
|
||
(princ " :next-text " stream)
|
||
(prin1 next-text stream)
|
||
(princ " :next-eol " stream)
|
||
(prin1 next-eol stream)))
|
||
|
||
|
||
|
||
(defun make-command-modify-text (command index before-text after-text)
|
||
(make-instance 'command-modify-text :previous command
|
||
:index index
|
||
:before-text before-text
|
||
:after-text after-text))
|
||
|
||
(defun make-command-join-node (command index previous-text previous-eol next-text next-eol)
|
||
(make-instance 'command-join-node :previous command
|
||
:index index
|
||
:previous-text previous-text
|
||
:previous-eol previous-eol
|
||
:next-text next-text
|
||
:next-eol next-eol))
|
||
|
||
(defun make-command-split-node (command index previous-text previous-eol next-text next-eol)
|
||
(make-instance 'command-split-node :previous command
|
||
:index index
|
||
:previous-text previous-text
|
||
:previous-eol previous-eol
|
||
:next-text next-text
|
||
:next-eol next-eol))
|
||
|
||
|
||
|
||
(defun modify-text (visual-index text &optional update-ui-p)
|
||
(multiple-value-bind (node index) (goto-visual-index visual-index)
|
||
(let ((next-command (make-command-modify-text *current-state* index
|
||
(raw-text-of node) text)))
|
||
(apply-command next-command update-ui-p)
|
||
(setf (next-of *current-state*) next-command)))
|
||
(when update-ui-p
|
||
(refresh-toolbar)))
|
||
|
||
(defun join-node (visual-index &optional update-ui-p)
|
||
(multiple-value-bind (node index) (goto-visual-index visual-index)
|
||
(let* ((previous (previous-of node))
|
||
(next-command (make-command-join-node *current-state* (1- index)
|
||
(raw-text-of previous) (line-ending-of previous)
|
||
(raw-text-of node) (line-ending-of node))))
|
||
(apply-command next-command update-ui-p)
|
||
(setf (next-of *current-state*) next-command)))
|
||
(when update-ui-p
|
||
(refresh-toolbar)))
|
||
|
||
(defun split-node (visual-index previous-text next-text &optional update-ui-p)
|
||
(multiple-value-bind (node index) (goto-visual-index visual-index)
|
||
(let* ((next-eol (line-ending-of node))
|
||
(previous-eol (if (/= (length next-eol) 0)
|
||
next-eol
|
||
(let ((prev (previous-of node)))
|
||
(if prev
|
||
(line-ending-of prev)
|
||
(coerce #(#\Newline) 'string)))))
|
||
(next-command (make-command-split-node *current-state* index
|
||
previous-text previous-eol
|
||
next-text next-eol)))
|
||
(apply-command next-command update-ui-p)
|
||
(setf (next-of *current-state*) next-command)))
|
||
(when update-ui-p
|
||
(refresh-toolbar))
|
||
|
||
|
||
|
||
(defun undo ()
|
||
(let ((previous-state (previous-of *current-state*)))
|
||
(unless (null previous-state)
|
||
(prog1
|
||
(index-of *current-state*)
|
||
(unapply-command *current-state* t)
|
||
(setf *current-state* previous-state)
|
||
(refresh-toolbar)))))
|
||
|
||
(defun can-undo-p ()
|
||
(not (null (and *current-state* (previous-of *current-state*))))))
|
||
|
||
(defun redo ()
|
||
(let ((next-state (next-of *current-state*)))
|
||
(unless (null next-state)
|
||
(prog1
|
||
(index-of next-state)
|
||
(apply-command next-state t)
|
||
(setf *current-state* next-state)
|
||
(refresh-toolbar)))))
|
||
|
||
(defun can-redo-p ()
|
||
(not (null (and *current-state* (next-of *current-state*)))))
|
||
|
||
(defun backup-pathname (pathname)
|
||
(flet ((escape-pathname (pathname)
|
||
(let ((directory (pathname-directory pathname)))
|
||
(format nil ".~{!~a~}!~a~@[.~a~].~~backup~~" (cdr directory) (pathname-name pathname) (pathname-type pathname)))))
|
||
(merge-pathnames (concatenate 'string "harbour-sextant/backups/" (escape-pathname pathname)) (uiop:xdg-cache-home))))
|
||
|
||
(defun save-file (filename &optional force)
|
||
(let ((pathname (parse-namestring filename)))
|
||
(when (or force (string= (hash-base64 (load-binary-file pathname)) *saved-hash*))
|
||
(unless (eq *saved-state* *current-state*)
|
||
(when (probe-file pathname)
|
||
(inferior-shell:run `(cp ,pathname
|
||
,(ensure-directories-exist (backup-pathname pathname)))))
|
||
(with-open-file (stream (ensure-directories-exist pathname)
|
||
:direction :output :if-exists :supersede)
|
||
(org-print (org-document) stream))
|
||
(setf *saved-state* *current-state*)
|
||
(setf *saved-hash* (hash-base64 (load-binary-file pathname)))
|
||
(let ((state *saved-state*))
|
||
(dotimes (i undo-history-size state)
|
||
(when (previous-of state)
|
||
(setf state (previous-of state))))
|
||
(unless (eql *initial-state* state)
|
||
(setf (next-of *initial-state*) state
|
||
(previous-of state) *initial-state*)))
|
||
(refresh-toolbar))
|
||
t)))
|
||
|
||
(defun can-save-p ()
|
||
(not (eq *saved-state* *current-state*)))
|
||
|
||
(defun refresh-toolbar ()
|
||
#+harbour-sextant
|
||
(qjs |refreshToolbar| "orgDocument"
|
||
(can-undo-p) (can-redo-p) (can-save-p)))
|
||
|
||
|
||
|
||
(defun commands-pathname (pathname)
|
||
(flet ((escape-pathname (pathname)
|
||
(let ((directory (pathname-directory pathname)))
|
||
(format nil ".~{!~a~}!~a~@[.~a~].~~commands~~" (cdr directory) (pathname-name pathname) (pathname-type pathname)))))
|
||
(merge-pathnames (concatenate 'string "harbour-sextant/commands/" (escape-pathname pathname)) (uiop:xdg-cache-home))))
|
||
|
||
(defun load-binary-file (pathname)
|
||
(with-open-file (stream pathname :direction :input
|
||
:if-does-not-exist nil
|
||
:element-type '(unsigned-byte 8))
|
||
(when stream
|
||
(let ((buffer (make-array (file-length stream) :element-type '(unsigned-byte 8))))
|
||
(read-sequence buffer stream)
|
||
buffer))))
|
||
|
||
(defun hash-base64 (buffer)
|
||
(if (or (null buffer) (= (length buffer) 0))
|
||
""
|
||
(with-output-to-string (stream)
|
||
(encode-base64-bytes (|hash.QCryptographicHash| buffer |QCryptographicHash.Sha1|)
|
||
stream))))
|
||
|
||
(defun load-commands (pathname)
|
||
(init-commands)
|
||
(let ((commands-pathname (commands-pathname pathname)))
|
||
(when (probe-file commands-pathname)
|
||
(let* ((commands (uiop:safe-read-file-form commands-pathname
|
||
:package :sextant/models/commands))
|
||
(sha (hash-base64 (load-binary-file pathname))))
|
||
(cond
|
||
((= (getf commands :version) 1)
|
||
(let ((saved-index (getf commands :saved-state))
|
||
(current-index (getf commands :current-state)))
|
||
(when (string= sha (getf commands :sha1))
|
||
(let ((command-count (loop with state = *initial-state*
|
||
for c in (getf commands :commands)
|
||
count c
|
||
while c
|
||
do (let ((command (apply #'make-instance c)))
|
||
(setf (next-of state) command
|
||
(previous-of command) state)
|
||
(setf state command)))))
|
||
(when (and (>= saved-index 0) (< saved-index command-count))
|
||
(dotimes (i saved-index)
|
||
(setf *saved-state* (next-of *saved-state*)))
|
||
(setf *current-state* *saved-state*)
|
||
(when (and (>= current-index 0) (<= current-index command-count))
|
||
(let ((c *current-state*))
|
||
(cond
|
||
((> current-index saved-index)
|
||
(dotimes (i (- current-index saved-index))
|
||
(setf *current-state* (next-of *current-state*))
|
||
(apply-command *current-state* nil)))
|
||
((< current-index saved-index)
|
||
(dotimes (i (- saved-index current-index))
|
||
(unapply-command *current-state* nil)
|
||
(setf *current-state* (previous-of *current-state*)))))))))))))))))
|
||
|
||
(defun save-commands (pathname)
|
||
(unless (or (null *initial-state*) (null (next-of *initial-state*)))
|
||
(let ((commands-pathname (commands-pathname pathname)))
|
||
(with-open-file (stream (ensure-directories-exist commands-pathname)
|
||
:direction :output :if-exists :supersede)
|
||
(princ "(:version 1 :sha1 \"" stream)
|
||
(princ *saved-hash* stream)
|
||
(princ "\" :saved-state " stream)
|
||
(princ (loop with index = 0
|
||
for c = *initial-state* then (next-of c)
|
||
while (and c (not (eq *saved-state* c)))
|
||
do (incf index)
|
||
finally (return (if c index -1))) stream)
|
||
(princ " :current-state " stream)
|
||
(princ (loop with index = 0
|
||
for c = *initial-state* then (next-of c)
|
||
while (and c (not (eq *current-state* c)))
|
||
do (incf index)
|
||
finally (return (if c index -1))) stream)
|
||
(terpri stream)
|
||
(princ ":commands" stream)
|
||
(terpri stream)
|
||
(princ "(" stream)
|
||
(loop for c = (next-of *initial-state*) then (next-of c)
|
||
while c
|
||
do (serialize-command c stream))
|
||
(terpri stream)
|
||
(princ "))" stream)
|
||
(terpri stream)))))
|
||
|
||
(defun initialize-commands (&optional pathname)
|
||
(setf *saved-state*
|
||
(setf *current-state*
|
||
(setf *initial-state*
|
||
(make-instance 'command-initial-state))))
|
||
(when pathname
|
||
(setf *saved-hash* (hash-base64 (load-binary-file pathname)))
|
||
(load-commands pathname))
|
||
(qlater #'refresh-toolbar))
|