[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/crdt 3f6f566 11/18: lots of changes
From: |
ELPA Syncer |
Subject: |
[elpa] externals/crdt 3f6f566 11/18: lots of changes |
Date: |
Thu, 9 Sep 2021 12:57:12 -0400 (EDT) |
branch: externals/crdt
commit 3f6f566a674e73313bf4e87ab4bf8069ca8369f8
Author: Qiantan Hong <qhong@mit.edu>
Commit: Qiantan Hong <qhong@mit.edu>
lots of changes
- better error recovery
- synchronize buffer local variable
- synchronize text property (only at text insertion time)
- comint integration
- follow user
---
HACKING.org | 31 +++-
crdt.el | 604 +++++++++++++++++++++++++++++++++++++++++++++---------------
2 files changed, 484 insertions(+), 151 deletions(-)
diff --git a/HACKING.org b/HACKING.org
index d5d2d66..996577a 100644
--- a/HACKING.org
+++ b/HACKING.org
@@ -157,7 +157,17 @@ and second last two bytes represent site ID.
#+END_SRC
+ return ::
- body takes the form =(site-id logical-clock success-p . return-values)=
+ body takes the form =(site-id logical-clock state-list success-p .
return-values)=
+
+ - Buffer local variables
+ + var :: body takes the form =(buffer-name variable-symbol . args)=
+ =args= is passed to the variable receiver =(get variable-symbol
'crdt-variable-receiver)=
+ to calculate an updated value.
+ The actual format of =args= depends on the variable sender and receiver
+ (which supposed implement some CRDT).
+
+ All peer must make sure they install the same kind of variable sender
and receiver
+ for =variable-symbol=.
- Remote Buffer Process
+ process ::
@@ -239,10 +249,15 @@ Development of the facility is still on-going.
+ [X] initial synchronization of major modes
+ [ ] toggle minor modes on the fly
+ [X] change major modes on the fly
- - [ ] set of synchronization primitives for buffer local variables
- + [ ] server dictated
+ - [-] set of synchronization primitives for buffer local variables
+ + [-] server dictated
+ + [ ] non incremental
+ + [X] naive incremental
+ + [ ] state-of-the-art level tree diff
+ [ ] a library of CRDTs
- - [ ] synchronize text properties (any use case for this?)
+ - [-] synchronize text properties (any use case for this?)
+ + [X] synchronize when new text is inserted
+ + [ ] synchronize when changed
- [ ] synchronize markers (any use case for this?)
- [-] remote command
+ [X] basic remote command (only possibly use =(point)=)
@@ -250,6 +265,14 @@ Development of the facility is still on-going.
+ [ ] correctly handle command that uses buffer content
+ [ ] handle arbitrary =interactive= form (firstly, what's the right
thing to do?)
- [-] remote buffer process
+ + [X] process mark
+ + [X] send to process
+ + [ ] make sure "pseudo process" really looks like process
+ (define complete set of advices)
+
+** Notes and examples of CRDTize built-in packages
+
+Search for =;;; Built-in package integrations= in ~crdt.el~
* TODO Cross-editor support
diff --git a/crdt.el b/crdt.el
index 8261418..f5c12c0 100644
--- a/crdt.el
+++ b/crdt.el
@@ -291,7 +291,8 @@ Must be used inside CRDT--WITH-INSERTION-INFORMATION."
network-process
network-clients
next-client-id
- buffer-table)
+ buffer-table
+ follow-site-id)
(defvar crdt--inhibit-update nil "When set, don't call CRDT--LOCAL-* on change.
This is useful for functions that apply remote change to local buffer,
@@ -326,11 +327,7 @@ Each element is of the form (CURSOR-OVERLAY .
REGION-OVERLAY).")
lamport-timestamp species front-advance rear-advance plist)
(crdt--defvar-permanent-local crdt--overlay-table nil
- "A hash table that maps CONSes of the form
(SITE-ID . LOGICAL-CLOCK) to overlays.")
-
-(defvar crdt--track-overlay-species nil)
-
-(crdt--defvar-permanent-local crdt--enabled-overlay-species nil)
+ "A hash table that maps CONSes of the form (SITE-ID . LOGICAL-CLOCK) to
overlays.")
(crdt--defvar-permanent-local crdt--buffer-network-name)
@@ -338,6 +335,25 @@ Each element is of the form (CURSOR-OVERLAY .
REGION-OVERLAY).")
(crdt--defvar-permanent-local crdt--buffer-pseudo-process)
+(defvar crdt--track-overlay-species nil
+ "Label any newly created overlay with its value as their ``species''.
+You usually want to dynamically bound this variable,
+so that overlays created during a dynamic extent
+are categorized into the same ``species''.
+You can then enable synchronizing those overlays using
+function CRDT--ENABLE-OVERLAY-SPECIES.")
+
+(defvar-local crdt--enabled-overlay-species nil
+ "A list of ``species'' of overlays that are tracked and synchronized.
+See CRDT--TRACK-OVERLAY-SPECIES.
+You should always use CRDT--ENABLE-OVERLAY-SPECIES
+and CRDT--DISABLE-OVERLAY-SPECIES to modify this variable
+as those functions handle bookkeeping of
+adding/removing actively tracked overlays.")
+
+(defvar-local crdt--enabled-text-properties nil
+ "A list of text properties that are tracked and synchronized.")
+
;;; Global variables
(defvar crdt--session-list nil)
@@ -463,6 +479,26 @@ This will hopefully trigger error recovery mechanism when
further unwinding the
(progn ,@ body)
(error (signal 'crdt-sync-error nil))))
+(defmacro crdt--with-should-not-error (name &rest body)
+ "When any error in BODY occur, print a report and stop CRDT in this buffer.
+NAME is included in the report."
+ (declare (indent 1) (debug (sexp def-body)))
+ `(condition-case err
+ (progn ,@ body)
+ (error
+ (ding)
+ (message "Error happens inside %s. This should never happen, please
submit an issue to crdt.el maintainers." ',name)
+ (message " Error: %s" err)
+ (message " Backtrace: ")
+ (backtrace)
+ (if (crdt--server-p)
+ (progn
+ (message "Stop sharing the buffer because of error.")
+ (crdt-stop-share-buffer))
+ (progn
+ (message "Killing the buffer because of error.")
+ (kill-buffer))))))
+
(defmacro crdt--with-buffer-name (name &rest body)
"Find CRDT shared buffer associated with NAME and evaluate BODY in it.
Any narrowing is temporarily disabled during evaluation of BODY.
@@ -529,7 +565,7 @@ after synchronization is completed."
map))
(define-derived-mode crdt-session-menu-mode tabulated-list-mode
- "CRDT User List"
+ "CRDT Session List"
(setq tabulated-list-format [("Session Name" 15 t)
("Role" 7 t)
("My Name" 15 t)
@@ -606,7 +642,7 @@ Only server can perform this action."
map))
(define-derived-mode crdt-buffer-menu-mode tabulated-list-mode
- "CRDT User List"
+ "CRDT Buffer List"
(setq tabulated-list-format [("Local Buffer" 15 t)
("Network Name" 30 t)
("Users" 15 t)]))
@@ -687,26 +723,32 @@ Only server can perform this action."
(interactive)
(if (crdt--server-p)
(let ((site-id (tabulated-list-get-id)))
- (if site-id
- (if (eq site-id (crdt--session-local-id crdt--session))
- (message "Suicide is not allowed.")
- (dolist (p (process-list))
- (when (eq (process-get p 'client-id) site-id)
- (delete-process p))))
- (message "We somehow don't have the SITE-ID for this user.
- Please submit a bug report to crdt.el maintainer.")))
+ (if (eq site-id (crdt--session-local-id crdt--session))
+ (error "Suicide is not allowed")
+ (dolist (p (process-list))
+ (when (eq (process-get p 'client-id) site-id)
+ (delete-process p)))))
(message "Only server can disconnect a user.")))
+(defun crdt-stop-follow ()
+ (message "Stop following %s."
+ (crdt--contact-metadata-display-name
+ (gethash (crdt--session-follow-site-id crdt--session)
+ (crdt--session-contact-table crdt--session))))
+ (setf (crdt--session-follow-site-id crdt--session) nil))
+
(defvar crdt-user-menu-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") #'crdt--user-menu-goto)
(define-key map [mouse-1] #'crdt--user-menu-goto)
(define-key map (kbd "k") #'crdt--user-menu-kill)
+ (define-key map (kbd "f") #'crdt--user-menu-follow)
map))
(define-derived-mode crdt-user-menu-mode tabulated-list-mode
"CRDT User List"
(setq tabulated-list-format [("Display Name" 15 t)
+ ("Follow" 7 t)
("Focused Buffer" 30 t)
("Address" 15 t)]))
@@ -735,7 +777,7 @@ Otherwise create a dedicated buffer."
(crdt-user-menu-mode)
(setq tabulated-list-entries nil)
(push (list (crdt--session-local-id crdt--session)
- (vector (crdt--session-local-name crdt--session)
+ (vector (crdt--session-local-name crdt--session) ""
(or (crdt--session-focused-buffer-name crdt--session)
"--")
"*myself*"))
tabulated-list-entries)
@@ -751,7 +793,9 @@ Otherwise create a dedicated buffer."
(put-text-property (1- (length colored-name))
(length colored-name)
'face `(:background
,(crdt--get-cursor-color k))
colored-name)
- (vector colored-name focused-buffer-name
(format "%s:%s" host service)))))
+ (vector colored-name (if (eq k
(crdt--session-follow-site-id crdt--session))
+ "yes" "")
+ focused-buffer-name (format "%s:%s"
host service)))))
tabulated-list-entries))
(crdt--session-contact-table crdt--session))
(tabulated-list-init-header)
@@ -763,6 +807,17 @@ Otherwise create a dedicated buffer."
(crdt-refresh-users (crdt--session-user-menu-buffer crdt--session)))
(crdt--refresh-buffers-maybe))
+(defun crdt--user-menu-follow ()
+ "Toggle following the user under point in CRDT user menu."
+ (interactive)
+ (let ((site-id (tabulated-list-get-id)))
+ (if (eq site-id (crdt--session-local-id crdt--session))
+ (error "Narcissism is not allowed")
+ (if (eq site-id (crdt--session-follow-site-id crdt--session))
+ (crdt-stop-follow)
+ (setf (crdt--session-follow-site-id crdt--session) site-id))
+ (crdt--refresh-users-maybe))))
+
(defun crdt--kill-buffer-hook ()
"Kill buffer hook for CRDT shared buffers.
It informs other peers that the buffer is killed."
@@ -775,6 +830,8 @@ It informs other peers that the buffer is killed."
(crdt--broadcast-maybe (crdt--format-message
`(focus ,(crdt--session-local-id crdt--session)
nil)))
(setf (crdt--session-focused-buffer-name crdt--session) nil))
+ (when (crdt--server-p)
+ (crdt-stop-share-buffer))
(crdt--refresh-users-maybe)))
;;; CRDT insert/delete
@@ -783,6 +840,30 @@ It informs other peers that the buffer is killed."
"Base64 encode STR if it's a string, or return NIL if STR is NIL."
(when str (base64-encode-string str)))
+(defsubst crdt--text-property-assimilate
+ (template template-beg template-end beg prop &optional object)
+ "Make PROP after BEG in OBJECT the same as part of TEMPLATE.
+The part between TEMPLATE-BEG and TEMPLATE-END is used.
+If OBJECT is NIL, use current buffer."
+ (let (next-pos
+ (pos template-beg)
+ (limit template-end)
+ (offset (- beg template-beg)))
+ (while (< pos limit)
+ (setq next-pos (next-single-property-change pos prop template limit))
+ (put-text-property (+ offset pos) (+ offset next-pos) prop
+ (get-text-property pos prop template)
+ object)
+ (setq pos next-pos))))
+
+(defsubst crdt--buffer-substring (beg end)
+ "Return the contents between BEG and END of the current buffer as a string.
+Copies text properties in CRDT--ENABLED-TEXT-PROPERTIES."
+ (let ((string (buffer-substring-no-properties beg end)))
+ (dolist (prop crdt--enabled-text-properties)
+ (crdt--text-property-assimilate nil beg end 0 prop string))
+ string))
+
(defun crdt--local-insert (beg end)
"To be called after a local insert happened in current buffer from BEG to
END.
Returns a list of (insert type) messages to be sent."
@@ -803,7 +884,7 @@ Returns a list of (insert type) messages to be sent."
(crdt--set-id-offset virtual-id (1+ left-offset))
(push `(insert ,crdt--buffer-network-name
,(base64-encode-string virtual-id) ,beg
- ,(buffer-substring-no-properties beg merge-end))
+ ,(crdt--buffer-substring beg merge-end))
resulting-commands))
(cl-incf left-offset (- merge-end beg))
(setq beg merge-end)))))
@@ -816,7 +897,7 @@ Returns a list of (insert type) messages to be sent."
(put-text-property beg block-end 'crdt-id (cons new-id t))
(push `(insert ,crdt--buffer-network-name
,(base64-encode-string new-id) ,beg
- ,(buffer-substring-no-properties beg block-end))
+ ,(crdt--buffer-substring beg block-end))
resulting-commands)
(setq beg block-end)
(setq left-offset (1- crdt--max-value)) ; this is always true when
we need to continue
@@ -826,7 +907,10 @@ Returns a list of (insert type) messages to be sent."
(defun crdt--find-id (id pos &optional before)
"Find the first position *after* ID if BEFORE is NIL or *before* ID
otherwise.
-Start the search from POS."
+Start the search from POS.
+This function doesn't handle empty string convention in the crdt.el protocol.
+To convert an ID in protocol message to a position in the buffer,
+CRDT--ID-TO-POS is usually more appropriate."
(let* ((left-pos (previous-single-property-change (min (1+ pos) (point-max))
'crdt-id nil (point-min)))
(left-id (crdt--get-starting-id left-pos))
@@ -965,57 +1049,52 @@ It saves the content to be changed (between BEG and END)
into CRDT--CHANGED-STRI
(defsubst crdt--crdt-id-assimilate (template beg &optional object)
"Make the CRDT-ID property after BEG in OBJECT the same as TEMPLATE.
TEMPLATE should be a string. If OBJECT is NIL, use current buffer."
- (let (next-pos
- (pos 0)
- (limit (length template)))
- (while (< pos limit)
- (setq next-pos (next-single-property-change pos 'crdt-id template limit))
- (put-text-property (+ beg pos) (+ beg next-pos) 'crdt-id
- (get-text-property pos 'crdt-id template)
- object)
- (setq pos next-pos))))
+ (crdt--text-property-assimilate template 0 (length template) beg 'crdt-id
object))
(defun crdt--after-change (beg end length)
"After change hook used by CRDT-MODE.
It examine (CRDT--CHANGED-STRING) (should be saved by CRDT--BEFORE-STRING)
and current content between BEG and END with LENGTH,
update the CRDT-ID for any newly inserted text, and send message to other
peers if needed."
- (when (markerp beg)
- (setq beg (marker-position beg)))
- (when (markerp end)
- (setq end (marker-position end)))
- (mapc (lambda (ov)
- (when (eq (overlay-get ov 'category) 'crdt-pseudo-cursor)
- (crdt--move-cursor ov beg)))
- (overlays-in beg (min (point-max) (1+ beg))))
- (when (crdt--session-local-id crdt--session) ; LOCAL-ID is NIL when a client
haven't received the first sync message
- (unless crdt--inhibit-update
- (let ((crdt--inhibit-update t))
- ;; we're only interested in text change
- ;; ignore property only changes
- (save-excursion
- (save-restriction
- (goto-char beg)
- (if (and (= length (- end beg))
- (string-equal (crdt--changed-string beg length)
- (buffer-substring-no-properties beg end)))
- (crdt--crdt-id-assimilate (crdt--changed-string beg length)
beg)
- (widen)
- (with-silent-modifications
- (unless (= length 0)
- (crdt--broadcast-maybe
- (crdt--format-message (crdt--local-delete beg end length))))
- (unless (= beg end)
- (dolist (message (crdt--local-insert beg end))
+ (crdt--with-should-not-error 'crdt--after-change
+ (when (markerp beg)
+ (setq beg (marker-position beg)))
+ (when (markerp end)
+ (setq end (marker-position end)))
+ (mapc (lambda (ov)
+ (when (eq (overlay-get ov 'category) 'crdt-pseudo-cursor)
+ (crdt--move-cursor ov beg)))
+ (overlays-in beg (min (point-max) (1+ beg))))
+ (when (crdt--session-local-id crdt--session) ; LOCAL-ID is NIL when a
client haven't received the first sync message
+ (unless crdt--inhibit-update
+ (let ((crdt--inhibit-update t))
+ ;; we're only interested in text change
+ ;; ignore property only changes
+ ;; todo: track properties in crdt--enabled-text-properties
+ (save-excursion
+ (save-restriction
+ (goto-char beg)
+ (if (and (= length (- end beg))
+ (string-equal (crdt--changed-string beg length)
+ (buffer-substring-no-properties beg end)))
+ (crdt--crdt-id-assimilate (crdt--changed-string beg length)
beg)
+ (widen)
+ (with-silent-modifications
+ (unless (= length 0)
(crdt--broadcast-maybe
- (crdt--format-message message))))))))
- ;; see if region stuff changed
- (let ((cursor-message (crdt--local-cursor)))
- (when cursor-message
- (crdt--broadcast-maybe (crdt--format-message cursor-message))))
- ;; process-mark synchronization is dependent on correct CRDT-ID
- ;; therefore we must do it after the insert/change stuff is done
- (crdt--send-process-mark-maybe)))))
+ (crdt--format-message (crdt--local-delete beg end
length))))
+ (unless (= beg end)
+ (dolist (message (crdt--local-insert beg end))
+ (crdt--broadcast-maybe
+ (crdt--format-message message))))))))
+ ;; see if region stuff changed
+ (let ((cursor-message (crdt--local-cursor)))
+ (when cursor-message
+ (crdt--broadcast-maybe (crdt--format-message cursor-message))))
+ ;; process-mark synchronization is dependent on correct CRDT-ID
+ ;; therefore we must do it after the insert/change stuff is done
+ (crdt--send-process-mark-maybe)
+ (crdt--send-variables-maybe))))))
;;; CRDT point/mark synchronization
@@ -1051,7 +1130,12 @@ If MARK-CRDT-ID is NIL, deactivate the pseudo region
overlay."
(setq ov-pair (puthash site-id (cons new-cursor new-region)
crdt--pseudo-cursor-table))))
(crdt--move-cursor (car ov-pair) point)
- (crdt--move-region (cdr ov-pair) point mark))
+ (crdt--move-region (cdr ov-pair) point mark)
+ (when (eq site-id (crdt--session-follow-site-id crdt--session))
+ (goto-char point)
+ (let ((cursor-message (crdt--local-cursor)))
+ (when cursor-message
+ (crdt--broadcast-maybe (crdt--format-message
cursor-message))))))
(when ov-pair
(remhash site-id crdt--pseudo-cursor-table)
(delete-overlay (car ov-pair))
@@ -1085,17 +1169,19 @@ Always return a message otherwise."
"Post command hook used by CRDT-MODE.
Check if focused buffer and cursor/mark position are changed.
Send message to other peers about any changes."
- (unless (eq crdt--buffer-network-name (crdt--session-focused-buffer-name
crdt--session))
- (crdt--broadcast-maybe
- (crdt--format-message `(focus ,(crdt--session-local-id crdt--session)
,crdt--buffer-network-name)))
- (setf (crdt--session-focused-buffer-name crdt--session)
crdt--buffer-network-name)
- (crdt--refresh-users-maybe))
- (let ((cursor-message (crdt--local-cursor)))
- (when cursor-message
- (crdt--broadcast-maybe (crdt--format-message cursor-message))))
- ;; process-mark synchronization is dependent on correct CRDT-ID
- ;; therefore we must do it after the insert/change stuff is done
- (crdt--send-process-mark-maybe))
+ (crdt--with-should-not-error crdt--post-command
+ (unless (eq crdt--buffer-network-name (crdt--session-focused-buffer-name
crdt--session))
+ (crdt--broadcast-maybe
+ (crdt--format-message `(focus ,(crdt--session-local-id crdt--session)
,crdt--buffer-network-name)))
+ (setf (crdt--session-focused-buffer-name crdt--session)
crdt--buffer-network-name)
+ (crdt--refresh-users-maybe))
+ (let ((cursor-message (crdt--local-cursor)))
+ (when cursor-message
+ (crdt--broadcast-maybe (crdt--format-message cursor-message))))
+ ;; process-mark synchronization is dependent on correct CRDT-ID
+ ;; therefore we must do it after the insert/change stuff is done
+ (crdt--send-process-mark-maybe)
+ (crdt--send-variables-maybe)))
;;; CRDT ID (de)serialization
@@ -1110,10 +1196,10 @@ If INCLUDE-CONTENT is non-NIL, the list contains STRING
instead of LENGTH."
(let ((prev-pos (previous-single-property-change pos 'crdt-id object
beg)))
(when (crdt--get-crdt-id-pair prev-pos object)
(push (cons (if include-content
- (cond ((not object) (buffer-substring-no-properties
prev-pos pos))
+ (cond ((not object) (crdt--buffer-substring prev-pos
pos))
((bufferp object)
(with-current-buffer object
- (buffer-substring-no-properties prev-pos
pos)))
+ (crdt--buffer-substring prev-pos pos)))
(t (substring object prev-pos pos)))
(- pos prev-pos))
(cl-destructuring-bind (id . eob)
(crdt--get-crdt-id-pair prev-pos object)
@@ -1175,13 +1261,17 @@ Return the string."
(print-length nil))
(prin1-to-string args)))
-(defun crdt--readable-encode (object)
+(cl-defun crdt--readable-encode (object &optional (no-properties t))
"Return an object ``similar'' to OBJECT at best effort.
+If NO-PROPERTIES is non-nil,
+omit text properties of any strings in the returned object.
The returned object has a printed representation that can be read back.
The symbol CRDT-EVAL is used as an special marker in the encoding
and the behavior is undefined if OBJECT itself contains this symbol."
(cl-typecase object
- ((or symbol string number character) object)
+ (string (if no-properties (substring-no-properties object) object))
+ ((or symbol number character) object)
+ (vector (cl-map 'vector #'crdt--readable-encode object))
(cons (cons (crdt--readable-encode (car object)) (crdt--readable-encode
(cdr object))))
(buffer (list 'crdt-eval 'buffer
(buffer-local-value 'crdt--buffer-network-name object)))
@@ -1190,15 +1280,16 @@ and the behavior is undefined if OBJECT itself contains
this symbol."
(defun crdt--readable-decode (object)
"Reconstruct the original object from CRDT--READABLE-ENCODEd OBJECT at best
effort."
- (if (consp object)
- (if (eq (car object) 'crdt-eval)
- (cl-case (cadr object)
- ((buffer) (crdt--with-buffer-name (caddr object) (current-buffer)))
- ((unreadable) (caddr object)))
- object)
- object))
-
-(defsubst crdt--log-network-traffic (message-string)
+ (cl-typecase object
+ (cons (if (eq (car object) 'crdt-eval)
+ (cl-case (cadr object)
+ ((buffer) (crdt--with-buffer-name (caddr object)
(current-buffer)))
+ ((unreadable) (caddr object)))
+ (cons (crdt--readable-decode (car object)) (crdt--readable-decode
(cdr object)))))
+ (vector (cl-map 'vector #'crdt--readable-decode object))
+ (t object)))
+
+(defsubst crdt--log-send-network-traffic (message-string)
(when crdt--log-network-traffic
(message "Send %s" message-string)))
@@ -1213,13 +1304,13 @@ send MESSAGE-STRING to server when WITHOUT is non-nil."
(dolist (client (crdt--session-network-clients crdt--session))
(when (and (eq (process-status client) 'open)
(not (eq (process-get client 'client-id) without)))
- (crdt--log-network-traffic message-string)
+ (crdt--log-send-network-traffic message-string)
(process-send-string client message-string)
;; (run-at-time 1 nil #'process-send-string client message-string)
;; ^ quick dirty way to simulate network latency, for debugging
))
(when without
- (crdt--log-network-traffic message-string)
+ (crdt--log-send-network-traffic message-string)
(process-send-string (crdt--session-network-process crdt--session)
message-string)
;; (run-at-time 1 nil #'process-send-string
(crdt--session-network-process crdt--session) message-string)
)))
@@ -1327,14 +1418,8 @@ CRDT--PROCESS should be bound to The network process for
the client connection."
,(car k) ,(cdr
k) ,prop ,value))))))
crdt--overlay-table)
- ;; synchronize process marker if there's any
- (let ((buffer-process (get-buffer-process buffer)))
- (when buffer-process
- (let ((mark-pos (marker-position (process-mark buffer-process))))
- (process-send-string crdt--process
- (crdt--format-message
- `(process-mark ,crdt--buffer-network-name
- ,(crdt--get-id mark-pos)
,mark-pos)))))))))
+ (crdt--send-process-mark-maybe nil)
+ (crdt--send-variables-maybe nil))))
(defun crdt--greet-client ()
"Send initial information when a client connects.
@@ -1499,7 +1584,10 @@ CRDT--PROCESS should be bound to The network process for
the client connection."
(crdt--session-contact-table crdt--session))
(let ((existing-item (gethash site-id (crdt--session-contact-table
crdt--session))))
(setf (crdt--contact-metadata-display-name existing-item)
display-name)))
- (remhash site-id (crdt--session-contact-table crdt--session)))
+ (progn
+ (when (eq site-id (crdt--session-follow-site-id crdt--session))
+ (crdt-stop-follow))
+ (remhash site-id (crdt--session-contact-table crdt--session))))
(crdt--refresh-users-maybe)
(crdt--broadcast-maybe crdt--message-string (process-get crdt--process
'client-id)))
@@ -1509,6 +1597,11 @@ CRDT--PROCESS should be bound to The network process for
the client connection."
;; (when (and (= site-id 0) (not crdt--focused-buffer-name))
;; (setq crdt--focused-buffer-name buffer-name)
;; (switch-to-buffer (gethash buffer-name (crdt--session-buffer-table
crdt--session))))
+ (when (eq site-id (crdt--session-follow-site-id crdt--session))
+ (crdt--with-buffer-name-pull buffer-name
+ (switch-to-buffer (current-buffer))
+ (let ((ov-pair (gethash site-id crdt--pseudo-cursor-table)))
+ (when ov-pair (goto-char (overlay-start (car ov-pair)))))))
(crdt--refresh-users-maybe)
(crdt--broadcast-maybe crdt--message-string (process-get crdt--process
'client-id)))
@@ -1534,6 +1627,8 @@ Handle received STRING from PROCESS."
(when crdt--log-network-traffic
(print message))
(setq string (buffer-substring-no-properties start (point)))
+ (delete-region (point-min) (point))
+ (goto-char (point-min))
(condition-case err
(if (or (not (crdt--server-p)) (process-get process
'authenticated))
(let ((crdt--inhibit-update t))
@@ -1551,14 +1646,13 @@ Handle received STRING from PROCESS."
(process-put process 'challenge
(gnutls-hash-mac 'SHA1 (substring
(process-get process 'password)) challenge))
(process-send-string process (crdt--format-message
`(challenge ,challenge))))))
- (error
+ ((crdt-unrecognized-message invalid-read-syntax)
(message "%s error when processing message %s from %s:%s,
disconnecting." err message
(process-contact process :host) (process-contact process
:service))
(if (crdt--server-p)
(delete-process process)
(crdt--stop-session crdt--session))))
- (delete-region (point-min) (point))
- (goto-char (point-min)))))))
+ )))))
(defun crdt--server-process-sentinel (client _message)
(let ((crdt--session (process-get client 'crdt-session)))
@@ -1618,7 +1712,6 @@ SESSION-NAME if provided is used in the prompt."
(crdt--broadcast-maybe
(crdt--format-message `(add
,crdt--buffer-network-name)))))
- (add-hook 'kill-buffer-hook #'crdt-stop-share-buffer nil t)
(crdt--refresh-buffers-maybe)
(crdt--refresh-sessions-maybe))
(error "Only server can add new buffer")))
@@ -2106,8 +2199,8 @@ Join with DISPLAY-NAME."
(let (vars vals)
(dolist (entry state-list)
(cl-case (car entry)
- ((point) (goto-char (apply #'crdt--find-id (cdr entry))))
- ((mark) (set-mark (apply #'crdt--find-id (cdr entry))))
+ ((point) (goto-char (apply #'crdt--id-to-pos (cdr entry))))
+ ((mark) (set-mark (apply #'crdt--id-to-pos (cdr entry))))
((mark-active transient-mark-mode last-command-event)
(push (car entry) vars)
(push (crdt--readable-decode (cadr entry)) vals))))
@@ -2131,57 +2224,66 @@ Join with DISPLAY-NAME."
(list t
(apply command-symbol (mapcar
#'crdt--readable-decode args)))
(error (list nil (car err) (crdt--readable-encode (cdr
err)))))
- (list nil 'crdt-access-denied))))
- (process-send-string crdt--process
- (crdt--format-message
- `(return ,site-id ,logical-clock
,@return-message)))))))))
+ (list nil 'crdt-access-denied)))
+ (msg (crdt--format-message
+ `(return ,site-id ,logical-clock
+ ,(crdt--assemble-state-list (get
command-symbol 'crdt-command-out-states))
+ ,@return-message))))
+ (crdt--log-send-network-traffic msg)
+ (process-send-string crdt--process msg)))))))
(defvar crdt--return-message-table (make-hash-table))
-(define-crdt-message-handler return (site-id logical-clock success-p &rest
return-values)
+(define-crdt-message-handler return (site-id logical-clock state-list
success-p &rest return-values)
(when (eq site-id (crdt--session-local-id crdt--session))
- (puthash logical-clock (cons success-p (crdt--readable-decode
return-values))
+ (puthash logical-clock (cl-list* state-list success-p
(crdt--readable-decode return-values))
crdt--return-message-table)))
-(defun crdt--make-remote-call (spawn-site-id function-symbol states args)
+(defun crdt--make-remote-call (spawn-site-id function-symbol in-states args)
"Send remote call request (a command type message) for FUNCTION-SYMBOL.
SPAWN-SITE-ID is the site where
the series (if any) of remote calls originally started.
-Assemble state list for items in STATES.
+Assemble state list for items in IN-STATES.
Request for calling FUNCTION-SYMBOL with ARGS."
- (let ((site-id (crdt--session-local-id crdt--session))
- (logical-clock (crdt--session-local-clock crdt--session)))
- (process-send-string (crdt--session-network-process crdt--session)
- (crdt--format-message
- `(command ,crdt--buffer-network-name ,spawn-site-id
- ,site-id ,logical-clock
- ,(crdt--assemble-state-list states)
- ,function-symbol ,@(mapcar
#'crdt--readable-encode args))))
+ (let* ((site-id (crdt--session-local-id crdt--session))
+ (logical-clock (crdt--session-local-clock crdt--session))
+ (msg (crdt--format-message
+ `(command ,crdt--buffer-network-name ,spawn-site-id
+ ,site-id ,logical-clock
+ ,(crdt--assemble-state-list in-states)
+ ,function-symbol ,@(mapcar #'crdt--readable-encode
args)))))
+ (crdt--log-send-network-traffic msg)
+ (process-send-string (crdt--session-network-process crdt--session) msg)
(cl-incf (crdt--session-local-clock crdt--session))
(while (not (gethash logical-clock crdt--return-message-table))
(sleep-for 0.1)
(thread-yield))
(let ((return-message (gethash logical-clock crdt--return-message-table)))
(remhash logical-clock crdt--return-message-table)
- (if (car return-message)
- (cadr return-message)
- (apply #'signal (cdr return-message))))))
+ (cl-destructuring-bind (state-list success-p &rest return-values)
return-message
+ (crdt--apply-state-list state-list)
+ (if success-p
+ (car return-values)
+ (apply #'signal return-values))))))
-(defun crdt--make-remote-command-advice (function-symbol &rest states)
+(defun crdt--make-remote-command-advice (function-symbol in-states)
(lambda (orig-fun &rest args)
(if (and crdt--session (not (crdt--server-p)))
(crdt--make-remote-call (crdt--session-local-id crdt--session)
- function-symbol states args)
+ function-symbol in-states args)
(apply orig-fun args))))
-(defun crdt-register-remote-command (command-symbol &rest states)
+(defun crdt-register-remote-command (command-symbol &optional in-states
out-states)
"Register COMMAND-SYMBOL as a remote command.
Allow remote calls to COMMAND-SYMBOL.
Delegate calls to COMMAND-SYMBOL at client side to the server.
Assume that COMMAND-SYMBOL, when invoked,
-make use of no more states other than those in STATES."
+make use of no more states other than those in IN-STATES.
+After executing the command on the server,
+OUT-STATES are sent back to the client."
(put command-symbol 'crdt-allow-remote-call t)
- (advice-add command-symbol :around (apply #'crdt--make-remote-command-advice
command-symbol states)
+ (put command-symbol 'crdt-command-out-states out-states)
+ (advice-add command-symbol :around (crdt--make-remote-command-advice
command-symbol in-states)
'((name . crdt-remote-command-advice))))
(defun crdt-unregister-remote-command (command-symbol)
@@ -2192,7 +2294,7 @@ Stop allowing remote calls to COMMAND-SYMBOL."
(defun crdt-register-remote-commands (command-entries)
"Register a list of remote commands according to COMMAND-ENTRIES.
-Each item in COMMAND-ENTRIES should have the form (COMMAND-SYMBOL . STATES)."
+Each item in COMMAND-ENTRIES should have the form (COMMAND-SYMBOL &optional
IN-STATES OUT-STATES)."
(dolist (entry command-entries)
(apply #'crdt-register-remote-command entry)))
@@ -2231,15 +2333,158 @@ Stop allowing remote calls to FUNCTION-SYMBOL."
(crdt-register-interaction-function 'read-from-minibuffer)
+;;; Buffer local variables
+
+(defvar crdt-variables nil)
+
+(cl-defun crdt--send-variables-maybe (&optional (incremental t))
+ (dolist (var crdt-variables)
+ (let ((sender (car (get var 'crdt-variable-scheme))))
+ (let ((msg (funcall sender var incremental)))
+ (unless (eq msg 'crdt-unchanged)
+ (crdt--broadcast-maybe (crdt--format-message
+ `(var ,crdt--buffer-network-name ,var
,@(crdt--readable-encode msg)))))))))
+
+(define-crdt-message-handler var (buffer-name variable-symbol . args)
+ (crdt--with-buffer-name buffer-name
+ (funcall (cdr (get variable-symbol 'crdt-variable-scheme))
+ variable-symbol args)))
+
+;; Tree diff
+;; We use it to provide an incremental variable sender/receiver for general
Lisp data structure.
+;; Currently we use a naive algorithm which should work reasonably well
+;; when there are few shape changes.
+;; The naive algorithm also runs in linear time and space.
+;; Sophiscated algorithms that computes minimal editing distance are usually
much more expensive.
+
+(defsubst crdt--exhaust-thunk (thunk)
+ "Keep forcing THUNK until it no longer returns a function.
+For poor man's TCO."
+ (while (functionp thunk)
+ (setq thunk (funcall thunk))))
+
+(defun crdt--diff (old new)
+ "Compute tree diff between OLD and NEW.
+The result DIFF can be used in (CRDT--NAPPLY-DIFF OLD DIFF) to reproduce NEW."
+ (let (result)
+ (cl-labels
+ ;; we could do a running length encoding of path
+ ;; not bothering that for now
+ ((process (path old new vindex)
+ (cl-typecase old
+ (cons (if (consp new)
+ (progn
+ (crdt--exhaust-thunk
+ (process (concat path "a") (car old) (car new) 0))
+ (lambda () (process (concat path "d") (cdr old) (cdr
new) 0)))
+ (push (list path new) result)))
+ (vector (cond ((not (vectorp new)) (push (list path new) result))
+ ((>= vindex (length old))
+ (unless (= (length old) (length new))
+ (push (list path (substring new vindex))
result)))
+ ((>= vindex (length new))
+ (push (list path nil) result))
+ (t
+ (crdt--exhaust-thunk
+ (process (concat path "a") (aref old vindex)
(aref new vindex) 0))
+ (lambda () (process (concat path "d") old new (1+
vindex))))))
+ (t (unless (eql old new) (push (list path new) result))))))
+ (crdt--exhaust-thunk (process nil old new 0))
+ result)))
+
+(defun crdt--napply-diff (old diff)
+ "Destructively apply DIFF produced by CRDT--DIFF to OLD."
+ ;; we could do them in one pass
+ ;; not bothering that for now
+ (dolist (update diff)
+ (cl-destructuring-bind (path new) update
+ (let ((cursor
+ (lambda (msg &optional data)
+ (cl-ecase msg
+ ((get) old)
+ ((set) (setq old data))
+ ((vindex) 0)))))
+ (dotimes (path-index (length path))
+ (let ((cursor-data (funcall cursor 'get)))
+ (cl-ecase (aref path path-index)
+ ((?a)
+ (cl-etypecase cursor-data
+ (cons (setq cursor
+ (lambda (msg &optional data)
+ (cl-ecase msg
+ ((get) (car cursor-data))
+ ((set) (rplaca cursor-data data))
+ ((vindex) 0)))))
+ (vector (setq cursor
+ (let ((vindex (funcall cursor 'vindex)))
+ (lambda (msg &optional data)
+ (cl-ecase msg
+ ((get) (aref cursor-data vindex))
+ ((set) (aset cursor-data vindex data))
+ ((vindex) 0))))))))
+ ((?d)
+ (cl-etypecase cursor-data
+ (cons
+ (setq cursor
+ (lambda (msg &optional data)
+ (cl-ecase msg
+ ((get) (cdr cursor-data))
+ ((set) (rplacd cursor-data data))
+ ((vindex) 0)))))
+ (vector (setq cursor
+ (let ((saved-cursor cursor)
+ (vindex (1+ (funcall cursor 'vindex))))
+ (lambda (msg &optional data)
+ (cl-ecase msg
+ ((get) cursor-data)
+ ((set)
+ (lambda ()
+ (funcall saved-cursor 'set
+ (if data
+ (vconcat cursor-data data)
+ (substring cursor-data 0
vindex)))))
+ ((vindex) vindex)))))))))))
+ (crdt--exhaust-thunk (funcall cursor 'set new)))))
+ old)
+
+(defun crdt--diff-server-variable-sender (var incremental)
+ (if (crdt--server-p)
+ (if incremental
+ (let ((diff (crdt--diff (get var 'crdt--diff-cache) (symbol-value
var))))
+ (if diff
+ (progn (put var 'crdt--diff-cache (copy-tree (symbol-value
var) t))
+ diff)
+ 'crdt-unchanged))
+ (list (list "" (symbol-value var))))
+ 'crdt-unchanged))
+
+(defun crdt--diff-server-variable-receiver (var args)
+ (unless (crdt--server-p)
+ (set var (crdt--napply-diff (symbol-value var) args))))
+
+(defvar crdt-variable-scheme-diff-server (cons
#'crdt--diff-server-variable-sender #'crdt--diff-server-variable-receiver))
+
+(defun crdt-register-variables (variable-entries)
+ (dolist (entry variable-entries)
+ (cl-destructuring-bind (var scheme) entry
+ (cl-pushnew var crdt-variables)
+ (put var 'crdt-variable-scheme (symbol-value scheme)))))
+
+(defun crdt-unregister-variables (variable-entries)
+ (dolist (entry variable-entries)
+ (cl-destructuring-bind (var _scheme) entry
+ (delq var crdt-variables)
+ (cl-remprop var 'crdt-variable-scheme))))
+
;;; Built-in package integrations
-;; xscheme.el
-(defvar xscheme-crdt-command-entries
- '((xscheme-send-region region)
- (xscheme-send-definition point)
- (xscheme-send-previous-expression point)
- (xscheme-send-next-expression point)
- (xscheme-send-current-line point)
+;; xscheme
+(defvar crdt-xscheme-command-entries
+ '((xscheme-send-region (region))
+ (xscheme-send-definition (point))
+ (xscheme-send-previous-expression (point))
+ (xscheme-send-next-expression (point))
+ (xscheme-send-current-line (point))
(xscheme-send-buffer)
(xscheme-send-char)
(xscheme-delete-output)
@@ -2248,10 +2493,10 @@ Stop allowing remote calls to FUNCTION-SYMBOL."
(xscheme-send-control-g-interrupt)
(xscheme-send-control-u-interrupt)
(xscheme-send-control-x-interrupt)
- (scheme-debugger-self-insert last-command-event)))
+ (scheme-debugger-self-insert (last-command-event))))
-(crdt-register-remote-commands xscheme-crdt-command-entries)
-;; xscheme.el doesn't use standard DEFINE-*-MODE facility
+(crdt-register-remote-commands crdt-xscheme-command-entries)
+;; xscheme doesn't use standard DEFINE-*-MODE facility
;; and doesn't call after-change-major-mode-hook.
;; Therefore we have to hack.
(advice-add 'scheme-interaction-mode-initialize :after
'crdt--after-change-major-mode)
@@ -2263,11 +2508,74 @@ Stop allowing remote calls to FUNCTION-SYMBOL."
;; Because it's done asynchronously in process filter,
;; and there seems to be no way to know the correct SPAWN-SITE-ID.
+;; comint
+(require 'ring)
+(defvar comint-input-ring)
+(defvar comint-input-ignoredups)
+(defvar comint-input-ring-size)
+
+(defvar crdt-comint-command-entries
+ '((comint-send-input (point) (point))
+ (comint-send-region (region) (region))))
+
+;; We also synchronize some buffer local variables to improve client side
completion.
+(defvar crdt-comint-variable-entries
+ '((comint-input-ring crdt-variable-scheme-diff-server)))
+
+(crdt-register-remote-commands crdt-comint-command-entries)
+(crdt-register-variables crdt-comint-variable-entries)
+
+(defcustom crdt-comint-share-input-history 'censor
+ "Share comint input history.
+If the value is censor,
+show only input history generated during a CRDT session to its peers,
+Merge with history generated before the session after the buffer is no longer
shared."
+ :type '(choice boolean (const censor)))
+
+(defvar-local crdt--comint-saved-input-ring nil)
+
+(defun crdt--merge-ring (old-ring delta-ring nodups)
+ (if delta-ring
+ (let ((old-ring (copy-tree old-ring t)))
+ (cl-loop for i from (1- (ring-length delta-ring)) downto 0
+ for item = (ring-ref delta-ring i)
+ do (if nodups
+ (let ((index (ring-member old-ring item)))
+ (when index
+ (ring-remove old-ring index))
+ (ring-insert old-ring item))
+ (ring-insert old-ring item))))
+ old-ring))
+
+(defsubst crdt--comint-effective-ring ()
+ (if crdt--comint-saved-input-ring
+ (crdt--merge-ring crdt--comint-saved-input-ring comint-input-ring
comint-input-ignoredups)
+ comint-input-ring))
+
+(defun crdt--comint-mode-hook ()
+ (when (derived-mode-p 'comint-mode)
+ (if crdt-mode
+ (progn
+ (add-to-list 'crdt--enabled-text-properties 'field)
+ (add-to-list 'crdt--enabled-text-properties 'front-sticky)
+ (add-to-list 'crdt--enabled-text-properties 'rear-nonsticky)
+ (cl-shiftf crdt--comint-saved-input-ring comint-input-ring
(make-ring comint-input-ring-size)))
+ (setq comint-input-ring (crdt--comint-effective-ring)
+ crdt--comint-saved-input-ring nil))))
+
+(defun crdt--comint-write-input-ring-advice (orig-func)
+ (if crdt-mode
+ (let ((comint-input-ring (crdt--comint-effective-ring)))
+ (funcall orig-func))
+ (funcall orig-func)))
+
+(add-hook 'comint-mode-hook #'crdt--comint-mode-hook)
+(add-hook 'crdt-mode-hook #'crdt--comint-mode-hook)
+
;;; pseudo process
(cl-defstruct (crdt--pseudo-process (:constructor crdt--make-pseudo-process))
- buffer
- mark)
+ buffer mark)
(defun crdt--pseudo-process-send-string (pseudo-process string)
(with-current-buffer (crdt--pseudo-process-buffer pseudo-process)
@@ -2323,12 +2631,12 @@ Stop allowing remote calls to FUNCTION-SYMBOL."
(crdt--make-pseudo-process :buffer (current-buffer)
:mark (point-marker)))
(setq crdt--last-process-mark-id crdt-id))))))))
-(defun crdt--send-process-mark-maybe ()
+(cl-defun crdt--send-process-mark-maybe (&optional (lazy t))
(let ((buffer-process (get-buffer-process (current-buffer))))
(when buffer-process
(let* ((mark-pos (marker-position (process-mark buffer-process)))
(current-id (crdt--get-id mark-pos)))
- (unless (string-equal crdt--last-process-mark-id current-id)
+ (unless (and lazy (string-equal crdt--last-process-mark-id current-id))
(setq crdt--last-process-mark-id current-id)
(crdt--broadcast-maybe
(crdt--format-message
@@ -2392,11 +2700,13 @@ Stop allowing remote calls to FUNCTION-SYMBOL."
(defun crdt--install-process-advices ()
"Globally enable advices for simulating remote buffer process.
-We don't install them by default because those advices sometimes seem to
interfere with other packages."
+Those advices seem to possibly interfere with other packages.
+Use CRDT--UNINSTALL-PROCESS-ADVICES to disable those advices for the rescue."
(dolist (pair crdt--process-advice-alist)
(advice-add (car pair) :around (cdr pair))))
(defun crdt--uninstall-process-advices ()
+ "Globally disable advices for simulating remote buffer process."
(dolist (pair crdt--process-advice-alist)
(advice-remove (car pair) (cdr pair))))
- [elpa] externals/crdt updated (4797413 -> c1378c5), ELPA Syncer, 2021/09/09
- [elpa] externals/crdt f9a7ec9 01/18: update header, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt dcf1dd5 02/18: Update version number, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt 605d8fa 07/18: initial experiment of xscheme.el integration, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt b6bcc8b 03/18: Merge branch 'master' into development, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt cc37dcd 04/18: add description of bridge protocol, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt bf1dc5d 09/18: typo, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt e4493e5 13/18: bug fix for comint integration, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt 52cbf50 15/18: autoload; fix bug for cmuscheme, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt 3f6f566 11/18: lots of changes,
ELPA Syncer <=
- [elpa] externals/crdt 38476da 05/18: Merge branch 'fix' into development, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt c08e21d 06/18: Refactors and remote command, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt 936418c 14/18: Synchronize text property on changes, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt e175d65 08/18: Remote command, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt 6b85d8a 10/18: refactor, replace cl-generic with hashtable of handlers, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt d7bc982 12/18: update README, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt 40bd5d4 16/18: document, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt b11bbc0 17/18: some more autoloads, ELPA Syncer, 2021/09/09
- [elpa] externals/crdt c1378c5 18/18: Merge branch 'development', ELPA Syncer, 2021/09/09