branch: externals/crdt
commit 70ae7ba0b9caacdce8c81f4d146ad291c3094bdc
Merge: cfe7748 9f5882c
Author: Qiantan Hong <qh...@mit.edu>
Commit: Qiantan Hong <qh...@mit.edu>
Merge branch 'fix' into 'master'
v0.1.2
See merge request qhong/crdt.el!2
---
crdt.el | 252 +++++++++++++++++++++++++++++++++++-----------------------------
1 file changed, 137 insertions(+), 115 deletions(-)
diff --git a/crdt.el b/crdt.el
index f2a6c04..727e055 100644
--- a/crdt.el
+++ b/crdt.el
@@ -1,4 +1,4 @@
-;;; crdt.el --- collaborative editing using Conflict-free Replicated Data
Types -*- lexical-binding: t; -*-
+;;; crdt.el --- Collaborative editing using Conflict-free Replicated Data
Types -*- lexical-binding: t; -*-
;; Copyright (C) 2021 Free Software Foundation, Inc.
@@ -6,7 +6,7 @@
;; Maintainer: Qiantan Hong <qh...@alum.mit.edu>
;; URL: https://code.librehq.com/qhong/crdt.el
;; Keywords: collaboration crdt
-;; Version: 0.1.1
+;; Version: 0.1.2
;; This file is part of GNU Emacs.
@@ -348,21 +348,22 @@ Each element is of the form (CURSOR-OVERLAY .
REGION-OVERLAY).")
;;; crdt-mode
+(defvar crdt--hooks-alist
+ '((after-change-functions . crdt--after-change)
+ (before-change-functions . crdt--before-change)
+ (post-command-hook . crdt--post-command)
+ (deactivate-mark-hook . crdt--post-command)
+ (kill-buffer-hook . crdt--kill-buffer-hook)))
+
(defun crdt--install-hooks ()
"Install the hooks used by CRDT-MODE."
- (add-hook 'after-change-functions #'crdt--after-change nil t)
- (add-hook 'before-change-functions #'crdt--before-change nil t)
- (add-hook 'post-command-hook #'crdt--post-command nil t)
- (add-hook 'deactivate-mark-hook #'crdt--post-command nil t)
- (add-hook 'kill-buffer-hook #'crdt--kill-buffer-hook nil t))
+ (dolist (pair crdt--hooks-alist)
+ (add-hook (car pair) (cdr pair) nil t)))
(defun crdt--uninstall-hooks ()
"Uninstall the hooks used by CRDT-MODE."
- (remove-hook 'after-change-functions #'crdt--after-change t)
- (remove-hook 'before-change-functions #'crdt--before-change t)
- (remove-hook 'post-command-hook #'crdt--post-command t)
- (remove-hook 'deactivate-mark-hook #'crdt--post-command t)
- (remove-hook 'kill-buffer-hook #'crdt--kill-buffer-hook t))
+ (dolist (pair crdt--hooks-alist)
+ (remove-hook (car pair) (cdr pair) t)))
(defsubst crdt--clear-pseudo-cursor-table ()
"Remove all overlays in CRDT--PSEUDO-CURSOR-TABLE.
@@ -403,17 +404,29 @@ Also set CRDT--PSEUDO-CURSOR-TABLE to NIL."
;;; Author visualization
(defsubst crdt--visualize-author-1 (beg end site)
- (put-text-property beg end
- 'font-lock-face `(:underline ,(crdt--get-cursor-color
site))))
+ (remove-overlays beg end 'category 'crdt-visualize-author)
+ (cl-flet ((ov-alike-p (ov)
+ (and (eq (overlay-get ov 'category) 'crdt-visualize-author)
+ (eq (overlay-get ov 'crdt-site) site))))
+ (or
+ (let ((ov-front (cl-find-if #'ov-alike-p (overlays-at (1- beg)))))
+ (when ov-front (move-overlay ov-front (overlay-start ov-front) end) t))
+ (let ((ov-rear (cl-find-if #'ov-alike-p (overlays-at end))))
+ (when ov-rear (move-overlay ov-rear beg (overlay-end ov-rear)) t))
+ (let ((new-ov (make-overlay beg end nil t nil)))
+ (overlay-put new-ov 'category 'crdt-visualize-author)
+ (overlay-put new-ov 'crdt-site site)
+ (overlay-put new-ov 'face `(:underline ,(crdt--get-cursor-color
site)))))))
+
(defun crdt--visualize-author ()
(save-restriction
(widen)
(let ((pos (point-max)))
- (while (> pos (point-min))
- (let* ((prev-pos (previous-single-property-change pos 'crdt-id nil
(point-min)))
- (crdt-id (car-safe (crdt--get-crdt-id-pair prev-pos))))
- (when crdt-id (crdt--visualize-author-1 prev-pos pos (crdt--id-site
crdt-id)))
- (setq pos prev-pos))))))
+ (while (> pos (point-min))
+ (let* ((prev-pos (previous-single-property-change pos 'crdt-id nil
(point-min)))
+ (crdt-id (car-safe (crdt--get-crdt-id-pair prev-pos))))
+ (when crdt-id (crdt--visualize-author-1 prev-pos pos (crdt--id-site
crdt-id)))
+ (setq pos prev-pos))))))
(define-minor-mode crdt-visualize-author-mode
"Minor mode to visualize who wrote what."
@@ -422,7 +435,7 @@ Also set CRDT--PSEUDO-CURSOR-TABLE to NIL."
(crdt--visualize-author)
(save-restriction
(widen)
- (remove-list-of-text-properties (point-min) (point-max)
'(font-lock-face)))))
+ (remove-overlays (point-min) (point-max) 'category
'crdt-visualize-author))))
;;; Shared buffer utils
@@ -436,6 +449,7 @@ If SESSION is nil, use current CRDT--SESSION."
(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.
Also, try to recover from synchronization error if any error happens in BODY.
Must be called when CURRENT-BUFFER is a CRDT status buffer.
If such buffer doesn't exist yet, do nothing."
@@ -444,11 +458,13 @@ If such buffer doesn't exist yet, do nothing."
(setq crdt-buffer (gethash ,name (crdt--session-buffer-table
crdt--session)))
(when (and crdt-buffer (buffer-live-p crdt-buffer))
(with-current-buffer crdt-buffer
- (condition-case err
- ,(cons 'progn body)
- (error (if (crdt--server-p)
- (signal (car err) (cdr err)) ; didn't implement server
side recovery yet
- (crdt--client-recover))))))))
+ (save-restriction
+ (widen)
+ (condition-case err
+ ,(cons 'progn body)
+ (error (if (crdt--server-p)
+ (signal (car err) (cdr err)) ; didn't implement server
side recovery yet
+ (crdt--client-recover)))))))))
(defmacro crdt--with-buffer-name-pull (name &rest body)
"Find CRDT shared buffer associated with NAME and evaluate BODY in it.
@@ -854,7 +870,9 @@ Start the search around POSITION-HINT."
(crdt--visualize-author-1 beg end (crdt--id-site id)))
;; work around for input method overlays
(cl-loop for ov in (overlays-at beg)
- do (unless (overlay-get ov 'crdt-meta)
+ do (unless (or (overlay-get ov 'crdt-meta)
+ (memq (overlay-get ov 'category)
+ '(crdt-visualize-author crdt-pseudo-cursor)))
(when (eq (overlay-start ov) beg)
(move-overlay ov end (overlay-end ov)))))
(with-silent-modifications
@@ -962,20 +980,21 @@ update the CRDT-ID for any newly inserted text, and send
message to other peers
;; we're only interested in text change
;; ignore property only changes
(save-excursion
- (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))
+ (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)))))))
+ (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))))))))
;; 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)
@@ -1041,10 +1060,12 @@ Always return a message otherwise."
(overlays-in (point-max) (point-max))))
(setq crdt--last-point point)
(setq crdt--last-mark mark)
- (let ((point-id-base64 (base64-encode-string (crdt--get-id point)))
- (mark-id-base64 (when mark (base64-encode-string (crdt--get-id
mark)))))
- `(cursor ,crdt--buffer-network-name ,(crdt--session-local-id
crdt--session)
- ,point ,point-id-base64 ,mark ,mark-id-base64)))))
+ (save-restriction
+ (widen)
+ (let ((point-id-base64 (base64-encode-string (crdt--get-id point)))
+ (mark-id-base64 (when mark (base64-encode-string (crdt--get-id
mark)))))
+ `(cursor ,crdt--buffer-network-name ,(crdt--session-local-id
crdt--session)
+ ,point ,point-id-base64 ,mark ,mark-id-base64))))))
(defun crdt--post-command ()
"Post command hook used by CRDT-MODE.
@@ -1059,7 +1080,6 @@ Send message to other peers about any changes."
(when cursor-message
(crdt--broadcast-maybe (crdt--format-message cursor-message)))))
-
;;; CRDT ID (de)serialization
(defun crdt--dump-ids (beg end object &optional omit-end-of-block-p
include-content)
@@ -1177,58 +1197,60 @@ The overlay is FRONT-ADVANCE and REAR-ADVANCE, and lies
between BEG and END."
"Send messages to a client about the full state of BUFFER.
The network process for the client connection is PROCESS."
(with-current-buffer buffer
- (process-send-string process
- (crdt--format-message
- `(sync
- ,crdt--buffer-network-name
- ,@ (crdt--dump-ids (point-min) (point-max) nil nil
t))))
- (process-send-string process (crdt--format-message `(ready
,crdt--buffer-network-name ,major-mode)))
-
- ;; synchronize cursor
- (maphash (lambda (site-id ov-pair)
- (cl-destructuring-bind (cursor-ov . region-ov) ov-pair
- (let* ((point (overlay-start cursor-ov))
- (region-beg (overlay-start region-ov))
- (region-end (overlay-end region-ov))
- (mark (if (eq point region-beg)
- (unless (eq point region-end) region-end)
- region-beg))
- (point-id-base64 (base64-encode-string (crdt--get-id
point)))
- (mark-id-base64 (when mark (base64-encode-string
(crdt--get-id mark)))))
- (process-send-string process
- (crdt--format-message
- `(cursor ,crdt--buffer-network-name
,site-id
- ,point ,point-id-base64
,mark ,mark-id-base64))))))
- crdt--pseudo-cursor-table)
- (process-send-string process (crdt--format-message (crdt--local-cursor
nil)))
-
- ;; synchronize tracked overlay
- (maphash (lambda (k ov)
- (let ((meta (overlay-get ov 'crdt-meta)))
- (process-send-string
- process
- (crdt--format-message (crdt--overlay-add-message
- (car k) (cdr k)
- (crdt--overlay-metadata-species meta)
- (crdt--overlay-metadata-front-advance
meta)
- (crdt--overlay-metadata-rear-advance
meta)
- (overlay-start ov)
- (overlay-end ov))))
- (cl-loop for (prop value) on (crdt--overlay-metadata-plist
meta) by #'cddr
- do (process-send-string
- process
- (crdt--format-message `(overlay-put
,crdt--buffer-network-name
- ,(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 process
- (crdt--format-message
- `(process-mark ,crdt--buffer-network-name
- ,(crdt--get-id mark-pos)
,mark-pos))))))))
+ (save-restriction
+ (widen)
+ (process-send-string process
+ (crdt--format-message
+ `(sync
+ ,crdt--buffer-network-name
+ ,@ (crdt--dump-ids (point-min) (point-max) nil
nil t))))
+ (process-send-string process (crdt--format-message `(ready
,crdt--buffer-network-name ,major-mode)))
+
+ ;; synchronize cursor
+ (maphash (lambda (site-id ov-pair)
+ (cl-destructuring-bind (cursor-ov . region-ov) ov-pair
+ (let* ((point (overlay-start cursor-ov))
+ (region-beg (overlay-start region-ov))
+ (region-end (overlay-end region-ov))
+ (mark (if (eq point region-beg)
+ (unless (eq point region-end) region-end)
+ region-beg))
+ (point-id-base64 (base64-encode-string (crdt--get-id
point)))
+ (mark-id-base64 (when mark (base64-encode-string
(crdt--get-id mark)))))
+ (process-send-string process
+ (crdt--format-message
+ `(cursor ,crdt--buffer-network-name
,site-id
+ ,point ,point-id-base64
,mark ,mark-id-base64))))))
+ crdt--pseudo-cursor-table)
+ (process-send-string process (crdt--format-message (crdt--local-cursor
nil)))
+
+ ;; synchronize tracked overlay
+ (maphash (lambda (k ov)
+ (let ((meta (overlay-get ov 'crdt-meta)))
+ (process-send-string
+ process
+ (crdt--format-message (crdt--overlay-add-message
+ (car k) (cdr k)
+ (crdt--overlay-metadata-species meta)
+
(crdt--overlay-metadata-front-advance meta)
+ (crdt--overlay-metadata-rear-advance
meta)
+ (overlay-start ov)
+ (overlay-end ov))))
+ (cl-loop for (prop value) on (crdt--overlay-metadata-plist
meta) by #'cddr
+ do (process-send-string
+ process
+ (crdt--format-message `(overlay-put
,crdt--buffer-network-name
+ ,(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 process
+ (crdt--format-message
+ `(process-mark ,crdt--buffer-network-name
+ ,(crdt--get-id mark-pos)
,mark-pos)))))))))
(defun crdt--greet-client (process)
"Send initial information when a client connects.
@@ -1512,13 +1534,14 @@ SESSION-NAME if provided is used in the prompt."
(setq crdt--buffer-network-name (buffer-name buffer))
(crdt-mode)
(save-excursion
- (widen)
- (let ((crdt--inhibit-update t))
- (with-silent-modifications
- (crdt--local-insert (point-min) (point-max))))
- (crdt--broadcast-maybe
- (crdt--format-message `(add
- ,crdt--buffer-network-name))))
+ (save-restriction
+ (widen)
+ (let ((crdt--inhibit-update t))
+ (with-silent-modifications
+ (crdt--local-insert (point-min) (point-max))))
+ (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))
@@ -1974,12 +1997,13 @@ Join with DISPLAY-NAME."
(if crdt-org-sync-overlay-mode
(progn
(save-excursion
- (widen)
- ;; heuristic to remove existing org overlays
- (cl-loop for ov in (overlays-in (point-min) (point-max))
- do (when (memq (overlay-get ov 'invisible)
- '(outline org-hide-block))
- (delete-overlay ov))))
+ (save-restriction
+ (widen)
+ ;; heuristic to remove existing org overlays
+ (cl-loop for ov in (overlays-in (point-min) (point-max))
+ do (when (memq (overlay-get ov 'invisible)
+ '(outline org-hide-block))
+ (delete-overlay ov)))))
(crdt--enable-overlay-species 'org))
(crdt--disable-overlay-species 'org)))
@@ -2110,14 +2134,12 @@ Join with DISPLAY-NAME."
(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."
- (mapcar (lambda (pair)
- (advice-add (car pair) :around (cdr pair)))
- crdt--process-advice-alist))
+ (dolist (pair crdt--process-advice-alist)
+ (advice-add (car pair) :around (cdr pair))))
(defun crdt--uninstall-process-advices ()
- (mapcar (lambda (pair)
- (advice-remove (car pair) (cdr pair)))
- crdt--process-advice-alist))
+ (dolist (pair crdt--process-advice-alist)
+ (advice-remove (car pair) (cdr pair))))
(cl-defmethod crdt-process-message ((message (head process)) _process)
(cl-destructuring-bind (buffer-name string) (cdr message)
