;;; workgroups-functions --- Functions you might find useful

;;; Commentary:

;;; Code:

(require 'workgroups-compat)

(require 'workgroups-variables)

(require 'workgroups-utils-basic)

(require 'workgroups-structs)

;;; session ops

(defun wg-current-session (&optional noerror)

  "Return `wg-current-session', setting it first if necessary."

  (or wg-current-session

      (unless noerror

        (error "No session is defined"))))

(defmacro wg-buf-list ()

  "setf'able `wg-current-session' buf-list slot accessor."

  `(wg-session-buf-list (wg-current-session)))

(defmacro wg-workgroup-list ()

  "setf'able `wg-current-session' modified slot accessor."

  `(wg-session-workgroup-list (wg-current-session)))

(defun wg-workgroup-list-or-error (&optional noerror)

  "Return the value of `wg-current-session's :workgroup-list slot."

  (or (wg-workgroup-list)

      (unless noerror

        (error "No workgroups are defined"))))

(defun wg-modified-p ()

  "Return t when the current session or any of its workgroups are modified."

  (or (wg-session-modified (wg-current-session))

      (cl-some 'wg-workgroup-modified (wg-workgroup-list))))

(defun wg-mark-everything-unmodified ()

  "Mark the session and all workgroups as unmodified."

  (setf (wg-session-modified (wg-current-session)) nil)

  (dolist (workgroup (wg-workgroup-list))

    (setf (wg-workgroup-modified workgroup) nil)))

(defun wg-workgroup-names (&optional noerror)

  "Return a list of workgroup names."

  (mapcar 'wg-workgroup-name (wg-workgroup-list-or-error noerror)))

;;; session parameters

(defun wg-session-parameter (session parameter &optional default)

  "Return SESSION's value for PARAMETER.

If PARAMETER is not found, return DEFAULT which defaults to nil.

SESSION nil defaults to the current session."

  (wg-aget (wg-session-parameters (or session (wg-current-session)))

           parameter default))

(defun wg-set-session-parameter (session parameter value)

  "Set SESSION's value of PARAMETER to VALUE.

SESSION nil means use the current session.

Return value."

  (let ((session (or session (wg-current-session))))

    (wg-set-parameter (wg-session-parameters session) parameter value)

    (setf (wg-session-modified session) t)

    value))

(defun wg-remove-session-parameter (session parameter)

  "Remove parameter PARAMETER from SESSION's parameters."

  (let ((session (or session (wg-current-session))))

    (wg-asetf (wg-session-parameters session) (wg-aremove it parameter))

    (setf (wg-session-modified session) t)))

(defun wg-session-local-value (variable &optional session)

  "Return the value of VARIABLE in SESSION.

SESSION nil defaults to the current session.  If VARIABLE does

not have a session-local binding in SESSION, the value is

resolved by Emacs."

  (let* ((undefined (cl-gensym))

         (value (wg-session-parameter session variable undefined)))

    (if (not (eq value undefined)) value

      (symbol-value variable))))

;;; buffer object utils

(defun wg-buffer-uid (buffer-or-name)

  "Return BUFFER-OR-NAME's buffer-local value of `wg-buffer-uid'."

  (buffer-local-value 'wg-buffer-uid (wg-get-buffer buffer-or-name)))

(defun wg-bufobj-uid (bufobj)

  "Return BUFOBJ's uid."

  (cl-etypecase bufobj

    (buffer (wg-buffer-uid bufobj))

    (wg-buf (wg-buf-uid bufobj))

    (string (wg-bufobj-uid (wg-get-buffer bufobj)))))

(defun wg-bufobj-name (bufobj)

  "Return BUFOBJ's buffer name."

  (cl-etypecase bufobj

;;; wconfig construction

(defun wg-buffer-special-data (buffer)

  "Return BUFFER's auxiliary serialization, or nil."

  (cl-some (lambda (fn) (funcall fn buffer)) wg-special-buffer-serdes-functions))

(defun wg-window-point (ewin)

  "Return `point' or :max.  See `wg-restore-point-max'.

EWIN should be an Emacs window object."

  (let ((p (window-point ewin)))

    (if (and wg-restore-point-max (= p (point-max))) :max p)))

(defun wg-serialize-buffer-local-variables ()

  "Return an alist of buffer-local variable symbols and their values.

See `wg-buffer-local-variables-alist' for details."

  (wg-docar (entry wg-buffer-local-variables-alist)

    (wg-dbind (var ser des) entry

      (when (local-variable-p var)

        (cons var (if ser (funcall ser) (symbol-value var)))))))

(defun wg-buffer-to-buf (buffer)

  "Return the serialization (a wg-buf) of Emacs buffer BUFFER."

  (with-current-buffer buffer

    (wg-make-buf

     :name           (buffer-name)

     :file-name      (buffer-file-name)

     :point          (point)

     :mark           (mark)

     :local-vars     (wg-serialize-buffer-local-variables)

     :special-data   (wg-buffer-special-data buffer))))

(defun wg-add-buffer-to-buf-list (buffer)

  "Make a buf from BUFFER, and add it to `wg-buf-list' if necessary.

If there isn't already a buf corresponding to BUFFER in

`wg-buf-list', make one and add it.  Return BUFFER's uid

in either case."

  (with-current-buffer buffer

    (setq wg-buffer-uid

          (wg-aif (wg-find-buffer-in-buf-list buffer (wg-buf-list))

              (wg-buf-uid it)

            (let ((buf (wg-buffer-to-buf buffer)))

              (push buf (wg-buf-list))

              (wg-buf-uid buf))))))

(defun wg-buffer-uid-or-add (buffer)

  "If there isn't already a buf corresponding to BUFFER in

`wg-buf-list', make one and add it.  Return BUFFER's uid

in either case."

  (or (wg-buffer-uid buffer) (wg-add-buffer-to-buf-list buffer)))

(defun wg-bufobj-uid-or-add (bufobj)

  "If BUFOBJ is a wg-buf, return its uid.

If BUFOBJ is a buffer or a buffer name, see `wg-buffer-uid-or-add'."

  (cl-etypecase bufobj

    (wg-buf (wg-buf-uid bufobj)) ;; possibly also add to `wg-buf-list'

    (buffer (wg-buffer-uid-or-add bufobj))

    (string (wg-bufobj-uid-or-add (wg-get-buffer bufobj)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;

;; Notes on buffer and window properties:

;;

;; fringes, margins and scroll-bars are properly properties of buffers, but

;; their settings can be forced ephemerally in a window with the set-window-foo

;; functions.

;;

;; window-point is a property of a buffer/window pair, but won't set properly

;; unless the buffer is current -- i.e. (set-window-buffer some-window

;; some-buffer) (set-window-point some-window 0)) won't set some-buffer's point

;; in some-window unless some-buffer is also current.

;;

;; window-start and window-hscroll are properties of buffer/window pairs.

;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun wg-window-to-win (window)

  "Return the serialization (a wg-win) of Emacs window WINDOW."

  (let ((selected (eq window (selected-window))))

    (with-selected-window window

      (wg-make-win

       :edges              (window-edges window)

       :point              (wg-window-point window)

       :start              (window-start window)

       :hscroll            (window-hscroll window)

       :selected           selected

       :minibuffer-scroll  (eq window minibuffer-scroll-window)

       :dedicated          (window-dedicated-p window)

       :buf-uid            (wg-buffer-uid-or-add (window-buffer window))))))

(defun wg-window-tree-to-wtree (window-tree)

  "Return the serialization (a wg-wtree) of Emacs window tree WINDOW-TREE."

  (wg-barf-on-active-minibuffer)

      ((inner (w) (if (windowp w) (wg-window-to-win w)

                    (wg-dbind (dir edges . wins) w

                      (wg-make-wtree

                       :dir    dir

                       :edges  edges

                       :wlist  (mapcar #'inner wins))))))

    (let ((w (car window-tree)))

      (when (and (windowp w) (window-minibuffer-p w))

        (error "Workgroups can't operate on minibuffer-only frames."))

      (inner w))))

(defun wg-frame-to-wconfig (&optional frame)

  "Return the serialization (a wg-wconfig) of Emacs frame FRAME.

FRAME nil defaults to `selected-frame'."

  (let* ((frame (or frame (selected-frame)))

         (fullscrn (frame-parameter frame 'fullscreen)))

    (wg-make-wconfig

     :left                  (frame-parameter frame 'left)

     :top                   (frame-parameter frame 'top)

     :width                 (frame-parameter frame 'width)

     :height                (frame-parameter frame 'height)

     :parameters            `((fullscreen . ,fullscrn))

     :vertical-scroll-bars  (frame-parameter frame 'vertical-scroll-bars)

     :scroll-bar-width      (frame-parameter frame 'scroll-bar-width)

     :wtree                 (wg-window-tree-to-wtree (window-tree frame))

     )))

(defun wg-current-wconfig ()

  "Return the current wconfig.

If `wg-current-wconfig' is non-nil, return it.  Otherwise return

`wg-frame-to-wconfig'."

  (or (frame-parameter nil 'wg-current-wconfig)

      (wg-frame-to-wconfig)))

(defmacro wg-with-current-wconfig (frame wconfig &rest body)

  "Eval BODY with WCONFIG current in FRAME.

FRAME nil defaults to `selected-frame'."

  (declare (indent 2))

  (wg-with-gensyms (frame-sym old-value)

    `(let* ((,frame-sym (or ,frame (selected-frame)))

            (,old-value (frame-parameter ,frame-sym 'wg-current-wconfig)))

       (unwind-protect

           (progn

             (set-frame-parameter ,frame-sym 'wg-current-wconfig ,wconfig)

             ,@body)

         (when (frame-live-p ,frame-sym)

           (set-frame-parameter ,frame-sym 'wg-current-wconfig ,old-value))))))

(defun wg-make-blank-wconfig (&optional buffer)

  "Return a new blank wconfig.

BUFFER or `wg-default-buffer' is visible in the only window."

  (save-window-excursion

    (delete-other-windows)

    (switch-to-buffer (or buffer wg-default-buffer))

    (wg-frame-to-wconfig)))

;;; win/wtree/wconfig utils

(defun wg-w-edges (w)

  "Return W's edge list."

  (cl-etypecase w

    (wg-win (wg-win-edges w))

    (wg-wtree (wg-wtree-edges w))))

(defun wg-copy-w (w)

  "Return a copy of W.  W should be a wg-win or a wg-wtree."

  (cl-etypecase w

    (wg-win (wg-copy-win w))

    (wg-wtree (wg-copy-wtree w))))

(defun wg-set-edges (w edges)

  "Set W's edge list, and return W."

  (cl-etypecase w

    (wg-win (setf (wg-win-edges w) edges))

    (wg-wtree (setf (wg-wtree-edges w) edges)))

  w)

(defun wg-min-size (dir)

  "Return the minimum window size in split direction DIR."

  (if dir wg-window-min-height wg-window-min-width))

(defun wg-actual-min-size (dir)

  "Return the actual minimum window size in split direction DIR."

  (if dir wg-actual-min-height wg-actual-min-width))

(defmacro wg-with-edges (w spec &rest body)

  "Bind W's edge list to SPEC and eval BODY."

  (declare (indent 2))

  `(wg-dbind ,spec (wg-w-edges ,w) ,@body))

(defmacro wg-with-bounds (wtree dir spec &rest body)

  "Bind SPEC to W's bounds in DIR, and eval BODY.

\"bounds\" are a direction-independent way of dealing with edge lists."

  (declare (indent 3))

  (wg-with-gensyms (dir-sym l1 t1 r1 b1)

    (wg-dbind (ls1 hs1 lb1 hb1) spec

      `(wg-with-edges ,wtree (,l1 ,t1 ,r1 ,b1)

         (cond (,dir (let ((,ls1 ,l1) (,hs1 ,r1) (,lb1 ,t1) (,hb1 ,b1))

                       ,@body))

               (t    (let ((,ls1 ,t1) (,hs1 ,b1) (,lb1 ,l1) (,hb1 ,r1))

                       ,@body)))))))

(defun wg-set-bounds (w dir ls hs lb hb)

  "Set W's edges in DIR with bounds LS HS LB and HB."

  (wg-set-edges w (if dir (list ls lb hs hb) (list lb ls hb hs))))

(defun wg-step-edges (edges1 edges2 hstep vstep)

  "Return W1's edges stepped once toward W2's by HSTEP and VSTEP."

  (wg-dbind (l1 t1 r1 b1) edges1

    (wg-dbind (l2 t2 r2 b2) edges2

      (let ((left (wg-step-to l1 l2 hstep))

            (top  (wg-step-to t1 t2 vstep)))

        (list left top

              (+ left (wg-step-to (- r1 l1) (- r2 l2) hstep))

              (+ top  (wg-step-to (- b1 t1) (- b2 t2) vstep)))))))

(defun wg-w-edge-operation (w edges op)

  "Return a copy of W with its edges mapped against EDGES through OP."

  (wg-set-edges w (cl-mapcar op (wg-w-edges w) edges)))

(defun wg-first-win (w)

  "Return the first actual window in W."

  (if (wg-win-p w) w

    (wg-first-win (car (wg-wtree-wlist w)))))

(defun wg-last-win (w)

  "Return the last actual window in W."

  (if (wg-win-p w) w

    (wg-last-win (wg-last1 (wg-wtree-wlist w)))))

(defun wg-minify-win (w)

  "Set W's edges to the smallest allowable."

  (let* ((edges (wg-w-edges w))

         (left (car edges))

         (top (cadr edges)))

    (wg-set-edges w (list left top

                          (+ left wg-actual-min-width)

                          (+ top  wg-actual-min-height)))))

(defun wg-minified-copy-of-last-win (w)

  "Minify a copy of the last actual window in W."

  (wg-minify-win (wg-copy-win (wg-last-win w))))

(defun wg-w-size (w &optional height)

  "Return the width or height of W, calculated from its edge list."

  (wg-with-edges w (l1 t1 r1 b1)

    (if height (- b1 t1) (- r1 l1))))

(defun wg-adjust-w-size (w width-fn height-fn &optional new-left new-top)

  "Adjust W's width and height with WIDTH-FN and HEIGHT-FN."

  (wg-with-edges w (left top right bottom)

    (let ((left (or new-left left)) (top (or new-top top)))

      (wg-set-edges (wg-copy-w w)

                    (list left

                          top

                          (+ left (funcall width-fn  (- right  left)))

                          (+ top  (funcall height-fn (- bottom top))))))))

(defun wg-scale-w-size (w width-scale height-scale)

  "Scale W's size by WIDTH-SCALE and HEIGHT-SCALE."

  (cl-flet

      ((wscale (width)  (truncate (* width  width-scale)))

       (hscale (height) (truncate (* height height-scale))))

    (wg-adjust-w-size w #'wscale #'hscale)))

(defun wg-equal-wtrees (w1 w2)

  "Return t when W1 and W2 have equal structure."

  (cond ((and (wg-win-p w1) (wg-win-p w2))

         (equal (wg-w-edges w1) (wg-w-edges w2)))

        ((and (wg-wtree-p w1) (wg-wtree-p w2))

         (and (eq (wg-wtree-dir w1) (wg-wtree-dir w2))

              (equal (wg-wtree-edges w1) (wg-wtree-edges w2))

              (cl-every #'wg-equal-wtrees

                     (wg-wtree-wlist w1)

                     (wg-wtree-wlist w2))))))

(defun wg-normalize-wtree (wtree)

  "Clean up and return a new wtree from WTREE.

Recalculate the edge lists of all subwins, and remove subwins

outside of WTREE's bounds.  If there's only one element in the

new wlist, return it instead of a new wtree."

  (if (wg-win-p wtree) wtree

    (wg-with-slots wtree ((dir wg-wtree-dir)

                          (wlist wg-wtree-wlist))

      (wg-with-bounds wtree dir (ls1 hs1 lb1 hb1)

        (let* ((min-size (wg-min-size dir))

               (max (- hb1 1 min-size))

               (lastw (wg-last1 wlist)))

              ((mapwl

                (wl)

                (wg-dbind (sw . rest) wl

                  (cons (wg-normalize-wtree

                         (wg-set-bounds

                          sw dir ls1 hs1 lb1

                          (setq lb1 (if (eq sw lastw) hb1

                                      (let ((hb2 (+ lb1 (wg-w-size sw dir))))

                                        (if (>= hb2 max) hb1 hb2))))))

                        (when (< lb1 max) (mapwl rest))))))

            (let ((new (mapwl wlist)))

              (if (not (cdr new)) (car new)

                (setf (wg-wtree-wlist wtree) new)

                wtree))))))))

(defun wg-scale-wtree (wtree wscale hscale)

  "Return a copy of WTREE with its dimensions scaled by WSCALE and HSCALE.

All WTREE's subwins are scaled as well."

  (let ((scaled (wg-scale-w-size wtree wscale hscale)))

    (if (wg-win-p wtree) scaled

      (wg-asetf (wg-wtree-wlist scaled)

                (wg-docar (sw it) (wg-scale-wtree sw wscale hscale)))

      scaled)))

(defun wg-scale-wconfigs-wtree (wconfig new-width new-height)

  "Scale WCONFIG's wtree with NEW-WIDTH and NEW-HEIGHT.

Return a copy WCONFIG's wtree scaled with `wg-scale-wtree' by the

ratio or NEW-WIDTH to WCONFIG's width, and NEW-HEIGHT to

WCONFIG's height."

  (wg-normalize-wtree

   (wg-scale-wtree

    (wg-wconfig-wtree wconfig)

    (/ (float new-width)  (wg-wconfig-width wconfig))

    (/ (float new-height) (wg-wconfig-height wconfig)))))

;; (wg-wconfig-width (wg-current-wconfig))

(defun wg-resize-frame-scale-wtree (wconfig)

  "Set FRAME's size to WCONFIG's, returning a possibly scaled wtree.

If the frame size was set correctly, return WCONFIG's wtree

unchanged.  If it wasn't, return a copy of WCONFIG's wtree scaled

with `wg-scale-wconfigs-wtree' to fit the frame as it exists."

  (let ((frame (selected-frame)))

    (wg-with-slots wconfig ((wcwidth wg-wconfig-width)

                            (wcheight wg-wconfig-height))

      (when window-system (set-frame-size frame wcwidth wcheight))

      (let ((fwidth  (frame-parameter frame 'width))

            (fheight (frame-parameter frame 'height)))

        (if (and (= wcwidth fwidth) (= wcheight fheight))

            (wg-wconfig-wtree wconfig)

          (wg-scale-wconfigs-wtree wconfig fwidth fheight))))))

(defun wg-reverse-wlist (w &optional dir)

  "Reverse W's wlist and those of all its sub-wtrees in direction DIR.

If DIR is nil, reverse WTREE horizontally.

If DIR is 'both, reverse WTREE both horizontally and vertically.

Otherwise, reverse WTREE vertically."

      ((inner (w) (if (wg-win-p w) w

                    (wg-with-slots w ((d1 wg-wtree-dir))

                      (wg-make-wtree

                       :dir d1

                       :edges (wg-wtree-edges w)

                       :wlist (let ((wl2 (mapcar #'inner (wg-wtree-wlist w))))

                                (if (or (eq dir 'both) (eq dir d1))

                                    (nreverse wl2)

                                  wl2)))))))

    (wg-normalize-wtree (inner w))))

(defun wg-wtree-move-window (wtree offset)

  "Offset `selected-window' OFFSET places in WTREE."

      ((inner (w) (if (wg-win-p w) w

                    (wg-with-slots w ((wlist wg-wtree-wlist))

                      (wg-make-wtree

                       :dir (wg-wtree-dir w)

                       :edges (wg-wtree-edges w)

                       :wlist (wg-aif (cl-find t wlist :key 'wg-win-selected)

                                  (wg-cyclic-offset-elt it wlist offset)

                                (mapcar #'inner wlist)))))))

    (wg-normalize-wtree (inner wtree))))

(defun wg-reverse-wconfig (wconfig &optional dir)

  "Reverse WCONFIG's wtree's wlist in direction DIR."

  (wg-asetf (wg-wconfig-wtree wconfig) (wg-reverse-wlist it dir))

  wconfig)

(defun wg-wconfig-move-window (wconfig offset)

  "Offset `selected-window' OFFSET places in WCONFIG."

  (wg-asetf (wg-wconfig-wtree wconfig) (wg-wtree-move-window it offset))

  wconfig)

(defun wg-flatten-wtree (wtree &optional key)

  "Return a new list by flattening WTREE.

KEY non returns returns a list of WTREE's wins.

KEY non-nil returns a list of the results of calling KEY on each win."

  (cl-flet

      ((inner (w) (if (wg-win-p w) (list (if key (funcall key w) w))

                    (cl-mapcan 'inner (wg-wtree-wlist w)))))

    (inner wtree)))

(defun wg-win-list (wtree)

  "Construct and return a list of all wg-wins in WTREE."

  (wg-flatten-wtree wtree))

(require 'workgroups-specialbufs)

(require 'workgroups-restore)

;;; workgroup utils

(defun wg-flag-workgroup-modified (workgroup)

  "Set WORKGROUP's and the current session's modified flags."

  (when wg-flag-modified

    (setf (wg-workgroup-modified workgroup) t)

    (setf (wg-session-modified (wg-current-session)) t)))

(defun wg-find-workgroup-by (slotkey value &optional noerror)

  "Return the workgroup on which ACCESSOR returns VALUE or error."

  (let ((accessor (cl-ecase slotkey

                    (:name 'wg-workgroup-name)

                    (:uid  'wg-workgroup-uid))))

    (or (cl-find value (wg-workgroup-list-or-error noerror) :test 'equal :key accessor)

        (unless noerror

          (error "No are no workgroups with a %S of %S"

                 accessor value)))))

(defun wg-first-workgroup ()

  "Return a first workgroup."

  (interactive)

  (car (wg-workgroup-list-or-error)))

(defun wg-current-workgroup (&optional noerror frame)

  "Return the current workgroup in FRAME, or error unless NOERROR."

  (or wg-current-workgroup

      (wg-aif (frame-parameter frame 'wg-current-workgroup-uid)

          (wg-find-workgroup-by :uid it noerror)

        (unless noerror (error "No current workgroup in this frame")))))

(defun wg-previous-workgroup (&optional noerror frame)

  "Return the previous workgroup in FRAME, or error unless NOERROR."

  (wg-aif (frame-parameter frame 'wg-previous-workgroup-uid)

      (wg-find-workgroup-by :uid it noerror)

    (unless noerror (error "No previous workgroup in this frame"))))

(defun wg-set-current-workgroup (workgroup &optional frame)

  "Set the current workgroup to WORKGROUP.

WORKGROUP should be a workgroup or nil."

  (set-frame-parameter frame 'wg-current-workgroup-uid

                       (when workgroup (wg-workgroup-uid workgroup))))

(defun wg-set-previous-workgroup (workgroup &optional frame)

  "Set the previous workgroup to WORKGROUP.

WORKGROUP should be a workgroup or nil."

  (set-frame-parameter frame 'wg-previous-workgroup-uid

                       (when workgroup (wg-workgroup-uid workgroup))))

(defun wg-current-workgroup-p (workgroup &optional frame)

  "Return t when WORKGROUP is the current workgroup, nil otherwise."

  (wg-awhen (wg-current-workgroup t frame)

    (eq workgroup it)))

(defun wg-previous-workgroup-p (workgroup &optional frame)

  "Return t when WORKGROUP is the previous workgroup, nil otherwise."

  (wg-awhen (wg-previous-workgroup t frame)

    (eq workgroup it)))

  '((integer    . identity)

    (float      . identity)

    (string     . identity)

    (symbol     . wg-pickel-symbol-serializer)

    (cons       . wg-pickel-cons-serializer)

    (vector     . wg-pickel-vector-serializer)

    (hash-table . wg-pickel-hash-table-serializer))

  "Alist mapping types to object serialization functions.")

(defvar wg-pickel-link-serializers

  '((cons       . wg-pickel-cons-link-serializer)

    (vector     . wg-pickel-vector-link-serializer)

    (hash-table . wg-pickel-hash-table-link-serializer))

  "Alist mapping types to link serialization functions.")

(defvar wg-pickel-object-deserializers

  '((s . wg-pickel-deserialize-uninterned-symbol)

    (c . wg-pickel-deserialize-cons)

    (v . wg-pickel-deserialize-vector)

    (h . wg-pickel-deserialize-hash-table))

  "Alist mapping type keys to object deserialization functions.")

(defvar wg-pickel-link-deserializers

  `((c . wg-pickel-cons-link-deserializer)

    (v . wg-pickel-vector-link-deserializer)

    (h . wg-pickel-hash-table-link-deserializer))

  "Alist mapping type keys to link deserialization functions.")

;;; errors and predicates

(put 'wg-pickel-unpickelable-type-error

     'error-conditions

     '(error wg-pickel-errors wg-pickel-unpickelable-type-error))

(put 'wg-pickel-unpickelable-type-error

     'error-message

     "Attemp to pickel unpickelable type")

(defun wg-pickelable-or-error (obj)

  "Error when OBJ isn't pickelable."

  (unless (memq (type-of obj) wg-pickel-pickelable-types)

    (signal 'wg-pickel-unpickelable-type-error

            (format "Can't pickel objects of type: %S" (type-of obj))))

  (cl-typecase obj

    (cons

     (wg-pickelable-or-error (car obj))

     (wg-pickelable-or-error (cdr obj)))

    (vector

     (cl-map nil 'wg-pickelable-or-error obj))

    (hash-table

     (wg-dohash (key value obj)

       (wg-pickelable-or-error key)

       (wg-pickelable-or-error value)))))

(defun wg-pickelable-p (obj)

  (condition-case err

      (progn (wg-pickelable-or-error obj) t)

    (wg-pickel-unpickelable-type-error nil)))

(defun wg-pickel-p (obj)

  "Return t when OBJ is a pickel, nil otherwise."

  (and (consp obj) (eq (car obj) wg-pickel-identifier)))

;; accessor functions

(defun wg-pickel-object-serializer (obj)

  "Return the object serializer for the `type-of' OBJ."

  (or (wg-aget wg-pickel-object-serializers (type-of obj))

      (error "Invalid type: %S" (type-of obj))))

(defun wg-pickel-link-serializer (obj)

  "Return the link serializer for the `type-of' OBJ."

  (wg-aget wg-pickel-link-serializers (type-of obj)))

(defun wg-pickel-object-deserializer (key)

  "Return the object deserializer for type key KEY, or error."

  (or (wg-aget wg-pickel-object-deserializers key)

      (error "Invalid object deserializer key: %S" key)))

(defun wg-pickel-link-deserializer (key)

  "Return the link deserializer for type key KEY, or error."

  (or (wg-aget wg-pickel-link-deserializers key)

      (error "Invalid link deserializer key: %S" key)))

;;; bindings

(defun wg-pickel-make-bindings-table (obj)

  "Return a table binding unique subobjects of OBJ to ids."

  (let ((binds (make-hash-table :test 'eq))

        (id -1))

     ((inner (obj)

           (unless (gethash obj binds)

              (puthash obj (cl-incf id) binds)

              (cl-case (type-of obj)

                (cons

                 (inner (car obj))

                 (inner (cdr obj)))

                (vector

                 (dotimes (idx (length obj))

                   (inner (aref obj idx))))

                (hash-table

                 (wg-dohash (key val obj)

                   (inner key)

                   (inner val)))))))

      (inner obj)

      binds)))

;;; object serialization

(defun wg-pickel-symbol-serializer (symbol)

  "Return SYMBOL's serialization."

  (cond ((eq symbol t) t)

        ((eq symbol nil) nil)

        ((intern-soft symbol) symbol)

        (t (list 's (symbol-name symbol)))))

(defun wg-pickel-cons-serializer (cons)

  "Return CONS's serialization."

  (list 'c))

(defun wg-pickel-vector-serializer (vector)

  "Return VECTOR's serialization."

  (list 'v (length vector)))

(defun wg-pickel-hash-table-serializer (table)

  "Return HASH-TABLE's serialization."

  (list 'h

        (hash-table-test table)

        (hash-table-size table)

        (hash-table-rehash-size table)

        (hash-table-rehash-threshold table)

        (hash-table-weakness table)))

(defun wg-pickel-serialize-objects (binds)

  "Return a list of serializations of the objects in BINDS."

  (let (result)

    (wg-dohash (obj id binds result)

      (setq result

            (nconc (list id (funcall (wg-pickel-object-serializer obj) obj))

                   result)))))

;;; link serialization

(defun wg-pickel-cons-link-serializer (cons binds)

  "Return the serialization of CONS's links in BINDS."

  (list 'c

        (gethash cons binds)

        (gethash (car cons) binds)

        (gethash (cdr cons) binds)))

(defun wg-pickel-vector-link-serializer (vector binds)

  "Return the serialization of VECTOR's links in BINDS."

  (let (result)

    (dotimes (i (length vector) result)

      (setq result

            (nconc (list 'v

                         (gethash vector binds)

                         i

                         (gethash (aref vector i) binds))

                   result)))))

(defun wg-pickel-hash-table-link-serializer (table binds)

  "Return the serialization of TABLE's links in BINDS."

  (let (result)

    (wg-dohash (key value table result)

      (setq result

            (nconc (list 'h

                         (gethash key binds)

                         (gethash value binds)

                         (gethash table binds))

                   result)))))

(defun wg-pickel-serialize-links (binds)

  "Return a list of serializations of the links between objects in BINDS."

  (let (result)

    (wg-dohash (obj id binds result)

      (wg-awhen (wg-pickel-link-serializer obj)

        (setq result (nconc (funcall it obj binds) result))))))

;;; object deserialization