WIP: Persist buffer state to history (for modes, tags and more)

source/buffer.lisp

@@ -38,7 +38,8 @@ inherited from the superclasses.")
     :documentation "Buffer profiles are used to specialize the behavior of
 various parts, such as the path of all data files.
 See also the `profile' slot in the `browser' class.")
-   (url (quri:uri ""))
+   (url (quri:uri "")
+        :type quri:uri)
    (url-at-point (quri:uri ""))
    (title "")
 
@@ -256,6 +257,16 @@ enabled before nyxt.atlas.engineer are restored.")
   (:metaclass user-class)
   (:documentation "A buffer whose behavior can be modified with `mode's."))
 
+(defmethod (setf c2mop:slot-value-using-class) :around (new-value
+                                                        (class user-class)
+                                                        (instance modable-buffer)
+                                                        slot)
+  (call-next-method
+   (if (eq 'previous-url (c2mop:slot-definition-name slot))
+       (ensure-url new-value)
+       new-value)
+   class instance slot))
+
 (defmethod finalize-buffer ((buffer modable-buffer) &key (browser *browser*) no-hook-p extra-modes)
   "Finalize instantiation of modable BUFFER.
 In particular,
@@ -266,6 +277,10 @@ This method should be called by the renderer after instantiating the web view
 of BUFFER."
   (unless no-hook-p
     (hooks:run-hook (buffer-make-hook browser) buffer))
+  ;; Modes may be initialized without a `buffer' slot (e.g. when deserialized).
+  (mapc (lambda (mode)
+          (setf (buffer mode) buffer))
+        (slot-value buffer 'modes))
   (mapc #'enable (slot-value buffer 'modes))
   (enable-modes* (append (reverse (default-modes buffer))
                          (uiop:ensure-list extra-modes))
@@ -284,6 +299,16 @@ buffer, with a meaningful result."
 To access all modes, including disabled ones, use `slot-value'."
   (sera:filter #'enabled-p (slot-value buffer 'modes)))
 
+(defmethod (setf modes) (value (buffer modable-buffer))
+  "Persist buffer state into history when changing mode."
+  (setf (slot-value buffer 'modes) value)
+  (when (context-buffer-p buffer)
+    (files:with-file-content (history (history-file buffer)
+                              :default (make-history-tree))
+      (alex:when-let ((owner (gethash (id buffer) (htree:owners history))))
+        (setf (htree:data (gethash (id buffer) (htree:owners history)))
+              (serialize-buffer buffer))))))
+
 (define-class input-buffer (buffer)
   ((keyscheme
     keyscheme:cua
@@ -412,6 +437,7 @@ down."))
 (define-class context-buffer (buffer)
   ((last-access
     (time:now)
+    :type time:timestamp
     :export nil
     :documentation "Timestamp when the buffer was last switched to.")
    (search-engines
@@ -872,6 +898,10 @@ Return the created buffer."
   ;; Background buffers are invisible to the browser.
   buffer)
 
+(defun serialize-buffer (buffer)
+  (with-output-to-string (out)
+    (s-serialization:serialize-sexp buffer out)))
+
 (defmethod customize-instance :after ((buffer context-buffer)
                                       &key parent-buffer no-history-p
                                       &allow-other-keys)
@@ -893,7 +923,8 @@ Return the created buffer."
                                                 (global-history-p buffer)
                                                 (not (nosave-buffer-p buffer))
                                                 (not (nosave-buffer-p parent-buffer)))
-                                       (id parent-buffer))))))
+                                       (id parent-buffer))
+                         :data (serialize-buffer buffer)))))
   buffer)
 
 (define-command update-document-model (&key (buffer (current-buffer)))
@@ -1070,6 +1101,84 @@ BUFFER's modes."
 
 (hooks:define-hook-type buffer (function (buffer)))
 
+(defun maybe-function-name (function-designator) ; TODO: Exists already?
+  (etypecase function-designator
+    (symbol function-designator)
+    (function
+     (let ((name (swank/backend:function-name function-designator)))
+       (if (listp name)
+           nil
+           name)))))
+
+(defmethod s-serialization::deserialize-sexp-slot ((self buffer) (slot-name (eql 'previous-url)) slot-value deserialized-objects)
+  ;; Need special case because previous-url can be NIL.
+  (declare (ignore slot-name deserialized-objects))
+  (when slot-value
+    (url slot-value)))
+
+(defmethod s-serialization:serialize-sexp-slot ((self hooks:hook) (slot (eql 'hooks:combination))
+                                                stream serialization-state)
+  (declare (ignore serialization-state))
+  (prin1 (or (maybe-function-name (slot-value self slot))
+             'hooks:default-combine-hook)
+         stream))
+(defmethod s-serialization:serialize-sexp-slot ((hook hooks:hook) (slot (eql 'hooks:handlers-alist))
+                                                stream serialization-sexp-slot)
+  (declare (ignore serialization-sexp-slot))
+  (prin1
+   (delete nil
+           (mapcar (lambda (handler-enable-p)
+                     (alex:when-let ((name (maybe-function-name (first handler-enable-p))))
+                       (cons name (second handler-enable-p))))
+                   (slot-value hook slot)))
+   stream))
+
+
+
+
+(defmethod s-serialization:serialize-sexp-slot ((self files:file) (slot (eql 'nfiles:read-handler))
+                                                stream serialization-state)
+  (declare (ignore serialization-state))
+  (prin1 (or (maybe-function-name (slot-value self slot))
+             'identity)
+         stream))
+(defmethod s-serialization:serialize-sexp-slot ((self files:file) (slot (eql 'nfiles:write-handler))
+                                                stream serialization-state)
+  (declare (ignore serialization-state))
+  (prin1 (or (maybe-function-name (slot-value self slot))
+             'identity)
+         stream))
+
+(defmethod s-serialization:serializable-slots ((buffer buffer))
+  "Discard document-model which is generated."
+  (set-difference (call-next-method)
+                  ;; Style is too big and not very useful to remember.
+                  '(style
+                    url-at-point)))
+
+(defmethod s-serialization:serializable-slots ((buffer document-buffer))
+  "Discard document-model which is generated."
+  (set-difference (call-next-method)
+                  '(document-model)))
+
+(defmethod s-serialization:serializable-slots ((buffer input-buffer))
+  "Discard document-model which is generated."
+  (set-difference (call-next-method)
+                  '(keyscheme
+                    last-event
+                    lisp-url-callbacks
+                    override-map)))
+
+(defmethod s-serialization:serializable-slots ((buffer web-buffer))
+  "Discard document-model which is generated."
+  (set-difference (call-next-method)
+                  '(keywords-document-model)))
+
+(defmethod s-serialization:serializable-slots ((buffer network-buffer))
+  "Discard document-model which is generated."
+  (set-difference (call-next-method)
+                  '(request-resource-keyscheme-map)))
+
 (define-command make-buffer (&rest args &key (title "") modes
                              (url (if *browser*
                                       (default-new-buffer-url *browser*)

source/history.lisp

@@ -199,14 +199,11 @@ lot."
         (*print-length* nil))
     ;; We need to make sure current package is :nyxt so that symbols are printed
     ;; with consistent namespaces.
-    (write
-     (with-input-from-string (in (with-output-to-string (out)
-                                   (s-serialization:serialize-sexp
-                                    (list +version+ (files:content file))
-                                    out)))
-       ;; We READ the output of serialize-sexp to make it more
-       ;; human-readable.
-       (safe-read in))
+    (pretty-print
+     (with-output-to-string (out)
+       (s-serialization:serialize-sexp
+        (list +version+ (files:content file))
+        out))
      :stream stream)))
 
 ;; REVIEW: This works around the issue of cl-prevalence to deserialize structs
@@ -334,10 +331,14 @@ Return non-NIL of history was restored, NIL otherwise."
                                     (htree:owner history owner-id))))
                  ;; Node-less owners can safely be ignored.
                  (when current-node
-                   (let ((new-buffer (make-buffer :title (title (htree:data current-node))
-                                                  :history-file history-file
-                                                  :url (url (htree:data current-node))
-                                                  :load-url-p nil)))
+                   (let ((new-buffer (alex:if-let ((data (htree:data owner)))
+                                       (with-input-from-string (in data)
+                                         (s-serialization:deserialize-sexp in))
+                                       ;; In case buffer was not serialized:
+                                       (make-buffer :title (title (htree:data current-node))
+                                                    :history-file history-file
+                                                    :url (url (htree:data current-node))
+                                                    :load-url-p nil))))
                      (setf (gethash owner-id old-id->new-id) (id new-buffer))
                      (setf (gethash (id new-buffer) new-owners) owner))))))
             (alex:hash-table-alist (htree:owners history)))
@@ -347,11 +348,12 @@ Return non-NIL of history was restored, NIL otherwise."
                        (gethash (htree:creator-id owner) old-id->new-id)))
                (htree:owners history))
       (setf (htree:owners history) new-owners))
-    (alex:when-let ((latest-id (first
-                                (first
-                                 (sort-by-time (alex:hash-table-alist (htree:owners history))
-                                               :key (compose #'htree:last-access #'rest))))))
-      (switch-buffer :buffer (buffers-get latest-id)))))
+    (alex:when-let* ((latest-id (first
+                                 (first
+                                  (sort-by-time (alex:hash-table-alist (htree:owners history))
+                                                :key (compose #'htree:last-access #'rest)))))
+                     (buffer (buffers-get latest-id)))
+      (switch-buffer :buffer buffer))))
 
 (defmethod files:deserialize ((profile nyxt-profile) (file history-file) raw-content &key)
   "Restore the global/buffer-local history and session from the PATH."

source/mode.lisp

@@ -592,6 +592,6 @@ If there is no corresponding keymap, return nil."
 
 (defmethod s-serialization:serializable-slots ((object mode))
   "Discard keymaps which can be quite verbose."
-  (delete 'keyscheme-map
-          (mapcar #'closer-mop:slot-definition-name
-                  (closer-mop:class-slots (class-of object)))))
+  (set-difference (call-next-method)
+                  '(keyscheme-map
+                    style)))

source/mode/autofill.lisp

@@ -58,6 +58,17 @@ it will be in conflict with common-lisp:fill."))
               (string (lambda () (autofill-fill autofill)))
               (function (autofill-fill autofill)))))
 
+(defmethod s-serialization:serialize-sexp-slot ((self autofill) (slot (eql 'fill))
+                                      stream serialization-state)
+  (declare (ignore serialization-state))
+  (let ((value (slot-value self slot)))
+    (prin1
+     (or (if (stringp value)
+             value
+             (nyxt::maybe-function-name value))
+         "")
+     stream)))
+
 (define-class autofill-source (prompter:source)
   ((prompter:name "Autofills")
    (prompter:constructor (autofills (find-submode 'autofill-mode)))

source/mode/repl.lisp

@@ -208,6 +208,11 @@ The `input' should be a valid Lisp code `read'-able in the `eval-package'.
 - and sets `raised-condition' (if any) to a wrapper class managing raised
   condition debugging."))
 
+(defmethod s-serialization:serialize-sexp-slot ((self lisp-cell) (slot (eql 'eval-package))
+                                                stream serialization-state)
+  (declare (ignore serialization-state))
+  (prin1 (package-name (slot-value self slot)) stream))
+
 (define-class cell-source (prompter:source)
   ((prompter:name "Cell types")
    (prompter:constructor (mopu:subclasses (find-class 'cell nil)))))

source/renderer/gtk.lisp

@@ -114,6 +114,14 @@ failures."))
   (append (call-next-method)
           `(("Context" ,(context-name buffer)))))
 
+(defmethod s-serialization:serializable-slots ((buffer gtk-buffer))
+  "Discard gtk-object which cannot be serialized."
+  (set-difference
+   (mapcar #'closer-mop:slot-definition-name
+           (closer-mop:class-slots (class-of buffer)))
+   '(gtk-object
+     handler-ids)))
+
 (defclass webkit-web-context (webkit:webkit-web-context) ()
   (:metaclass gobject:gobject-class))
 

source/search-engine.lisp

@@ -33,6 +33,13 @@ Simple completion functions can be built via `make-search-completion-function'")
   (:export-class-name-p t)
   (:export-accessor-names-p t))
 
+(defmethod s-serialization:serialize-sexp-slot ((self search-engine) (slot (eql 'completion-function))
+                                                stream serialization-state)
+  (declare (ignore serialization-state))
+  (prin1
+   (nyxt::maybe-function-name (slot-value self slot))
+   stream))
+
 (defmethod fallback-url ((engine search-engine))
   (or (slot-value engine 'fallback-url)
       (quri:uri (format nil (search-url engine) ""))))

source/urls.lisp

@@ -248,6 +248,10 @@ If it cannot be derived, return an empty `quri:uri'."
            (or (ignore-errors (quri:uri thing))
                (quri:uri "")))))
 
+(defmethod coerce-slot (new-value instance (slot-type (eql 'quri:uri)))
+  (declare (ignorable instance slot-type))
+  (ensure-url new-value))
+
 (-> url-empty-p ((or quri:uri string null)) boolean)
 (export-always 'url-empty-p)
 (defun url-empty-p (url)

source/user-classes.lisp

@@ -82,6 +82,34 @@ Do not specialize the standard method in public code, prefer
     (or (typep metaclass 'user-class)
         (typep metaclass 'user-funcallable-class))))
 
+(export-always 'coerce-slot)
+(defgeneric coerce-slot (new-value instance slot-type)
+  (:method ((new-value t) (instance t) (slot-type t))
+    (declare (ignore instance slot-type))
+    new-value)
+  (:documentation "Coerce NEW-VALUE to a return value that should satisfy SLOT-TYPE.
+This applies to all slots of INSTANCE.
+To coerce the value for a specific slot, see `c2mop:slot-value-using-class'."))
+
+(defmethod coerce-slot (new-value instance (slot-type (eql 'local-time:timestamp)))
+  (declare (ignorable instance slot-type))
+  (if (typep new-value 'local-time:timestamp)
+      new-value
+      (local-time:parse-timestring new-value)))
+
+(defmethod coerce-slot (new-value instance (slot-type (eql 'package)))
+  (declare (ignorable instance slot-type))
+  (if (typep new-value 'package)
+      new-value
+      (find-package new-value)))
+
+(defmethod (setf c2mop:slot-value-using-class) :around (new-value
+                                                        (class user-class)
+                                                        instance
+                                                        slot)
+  (call-next-method (coerce-slot new-value instance (c2mop:slot-definition-type slot))
+                    class instance slot))
+
 (defclass interface-class (standard-class) ()
   (:documentation "An interface class exists solely for the purpose of
 dereferencing other classes through its superclasses.

source/utilities.lisp

@@ -193,6 +193,16 @@ This is useful if you do not trust the input."
     (uiop:with-safe-io-syntax (:package package)
       (read input-stream eof-error-p eof-value recursive-p))))
 
+(export-always 'pretty-print)
+(defun pretty-print (s &key (stream t))
+  "Format s-expression in string S using the pretty printer."
+  (write
+   (with-input-from-string (in s)
+     ;; We READ the output of serialize-sexp to make it more
+     ;; human-readable.
+     (safe-read in))
+   :stream stream))
+
 (export-always 'safe-sort)
 (defun safe-sort (s &key (predicate #'string-lessp) (key #'string))
   "Sort sequence S of objects by KEY using PREDICATE."