Re: read syntax for window configs

[Michael Sperber <sperber@deinprogramm.de>]

[-- Attachment #1: Type: text/plain, Size: 548 bytes --]


"Drew Adams" <drew.adams@oracle.com> writes:

>> >  > Since XEmacs have lots of other object types, maybe 
>> >  > XEmacs already has a read syntax for window configurations
>> 
>> Window configurations in XEmacs don't have read syntax, but they're
>> pretty close, and thus it wouldn't be hard to do.
>
> Read syntax for window (and frame) configs would be very welcome.

I've attached code that works for XEmacs.  Is this along the line of
what you'd like?

-- 
Cheers =8-} Mike
Friede, Völkerverständigung und überhaupt blabla

[-- Attachment #2: Type: text/plain, Size: 5118 bytes --]

(defun window-configuration->sexp (config)
  "Convert a window configuration to a readable S-expression."
  `(window-configuration
    (frame . ,(position (window-configuration-frame config) (frame-list))) ; lame, but the best we can do
    (frame-top . ,(window-configuration-frame-top config))
    (frame-left . ,(window-configuration-frame-left config))
    (frame-pixel-width . ,(window-configuration-frame-pixel-width config))
    (frame-pixel-height . ,(window-configuration-frame-pixel-height config))
    (current-buffer . ,(buffer-name (window-configuration-current-buffer config)))
    (minibuffer-pixel-height . ,(window-configuration-minibuffer-pixel-height config))
    (min-width . ,(window-configuration-min-width config))
    (min-height . ,(window-configuration-min-height config))
    (saved-root-window . ,(saved-window->sexp (window-configuration-saved-root-window config)))))

(defun saved-window->sexp (saved)
  "Convert a saved-window structure to a readable S-expression."
  `(saved-window
    (currentp . ,(saved-window-currentp saved))
    (minibufferp . ,(saved-window-minibuffer-scrollp saved))
    (minibuffer-scrollp . ,(saved-window-minibuffer-scrollp saved))
    (buffer . ,(buffer-name (saved-window-buffer saved)))
    (mark-marker . ,(maybe-marker-position (saved-window-mark-marker saved)))
    (start-marker . ,(maybe-marker-position (saved-window-start-marker saved)))
    (point-marker . ,(maybe-marker-position (saved-window-point-marker saved)))
    (pixel-left . ,(saved-window-pixel-left saved))
    (pixel-top . ,(saved-window-pixel-top saved))
    (pixel-right . ,(saved-window-pixel-right saved))
    (pixel-bottom . ,(saved-window-pixel-bottom saved))
    (hscroll . ,(saved-window-hscroll saved))
    (modeline-hscroll . ,(saved-window-modeline-hscroll saved))
    (dedicatedp . ,(saved-window-dedicatedp saved))
    (first-hchild . ,(maybe-saved-window->sexp (saved-window-first-hchild saved)))
    (first-vchild . ,(maybe-saved-window->sexp (saved-window-first-vchild saved)))
    (next-child . ,(maybe-saved-window->sexp (saved-window-next-child saved)))))

(defun maybe-saved-window->sexp (saved)
  "Like `saved-window->sexp', but also accepts nil."
  (and saved (saved-window->sexp saved)))

(defun maybe-marker-position (marker)
  "Extract position from marker, or return nil for nil marker."
  (and marker (marker-position marker)))

(defun sexp->window-configuration (sexp)
  "Convert return value of `window-configuration->sexp' back into window config."
  (make-window-configuration
   :frame (let ((pos (sexp-tag->value sexp 'frame))
		(frames (frame-list)))
	    (if (< pos (length frames))
		(nth pos frames)
	      (car frames)))
   :frame-top (sexp-tag->value sexp 'frame-top)
   :frame-left (sexp-tag->value sexp 'frame-left)
   :frame-pixel-width (sexp-tag->value sexp 'frame-pixel-width)
   :frame-pixel-height (sexp-tag->value sexp 'frame-pixel-height)
   :current-buffer (get-buffer-create (sexp-tag->value sexp 'current-buffer))
   :min-width (sexp-tag->value sexp 'min-width)
   :min-height (sexp-tag->value sexp 'min-height)
   :minibuffer-pixel-height (sexp-tag->value sexp 'minibuffer-pixel-height)
   :saved-root-window (sexp->saved-window (sexp-tag->value sexp 'saved-root-window))))

(defun sexp->saved-window (sexp)
  "Convert return value of `saved-window->sexp' back into saved window."
  (let ((buf (get-buffer-create (sexp-tag->value sexp 'buffer))))
    (make-saved-window
     :window nil			; sorry
     :currentp (sexp-tag->value sexp 'currentp)
     :minibufferp (sexp-tag->value sexp 'minibufferp)
     :minibuffer-scrollp (sexp-tag->value sexp 'minibuffer-scrollp)
     :buffer buf
     :mark-marker (maybe-marker-position->marker buf (sexp-tag->value sexp 'mark-marker))
     :start-marker (maybe-marker-position->marker buf (sexp-tag->value sexp 'start-marker))
     :point-marker (maybe-marker-position->marker buf (sexp-tag->value sexp 'point-marker))
     :pixel-left (sexp-tag->value sexp 'pixel-left)
     :pixel-top (sexp-tag->value sexp 'pixel-top)
     :pixel-right (sexp-tag->value sexp 'pixel-right)
     :pixel-bottom (sexp-tag->value sexp 'pixel-bottom)
     :hscroll (sexp-tag->value sexp 'hscroll)
     :modeline-hscroll (sexp-tag->value sexp 'modeline-hscroll)
     :dedicatedp (sexp-tag->value sexp 'dedicatedp)
     :first-hchild (maybe-sexp->saved-window (sexp-tag->value sexp 'first-hchild))
     :first-vchild (maybe-sexp->saved-window (sexp-tag->value sexp 'first-vchild))
     :next-child (maybe-sexp->saved-window (sexp-tag->value sexp 'next-child)))))

(defun maybe-sexp->saved-window (sexp)
  "Like `sexp->saved-window', but accepts nil."
  (and sexp (sexp->saved-window sexp)))

(defun sexp-tag->value (sexp tag)
  "Extract value for tag in S-expression sexp.
This works for the values returned by `window-configuration->sexp' and
`saved-window->sexp'.  Returns nil if the tag is not there."
  (cdr (assq tag (cdr sexp))))

(defun maybe-marker-position->marker (buffer pos)
  "Turn nil or a marker position into a marker."
  (let ((marker (make-marker)))
    (set-marker marker pos buffer)
    marker))