Changeset - 061700c825b7
[Not reviewed]
0 4 0
Sergey Pashinin - 12 years ago 2014-02-26 00:10:50
sergey@pashinin.com
More fixes to cl-functions
4 files changed with 13 insertions and 13 deletions:
0 comments (0 inline, 0 general)
src/workgroups-functions.el
Show inline comments
 
@@ -410,49 +410,49 @@ BUFFER or `wg-default-buffer' is visible in the only window."
 
                          (+ 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
 
  (cl-labels
 
      ((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)
 
@@ -534,51 +534,51 @@ Otherwise, reverse WTREE vertically."
 
      ((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
 
  (cl-labels
 
      ((inner (w) (if (wg-win-p w) (list (if key (funcall key w) w))
 
                    (cl-mapcan 'inner (wg-wtree-wlist 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))))
 
@@ -1183,49 +1183,49 @@ BUFFER nil defaults to `current-buffer'."
 
(defun wg-session-all-buf-uids (&optional session)
 
  "Return a new list of all unique buf uids in SESSION.
 
SESSION nil defaults to `wg-current-session'."
 
  (cl-reduce 'wg-string-list-union
 
          (wg-session-workgroup-list (or session (wg-current-session)))
 
          :key 'wg-workgroup-all-buf-uids))
 

	
 
(defun wg-buffer-list-all-uids (&optional buffer-list)
 
  "Return a list of the uids of all buffers in BUFFER-LIST in
 
which `wg-buffer-uid' is locally bound.
 
BUFFER-LIST nil defaults to `buffer-list'."
 
  (delq nil (mapcar 'wg-buffer-uid (or buffer-list (buffer-list)))))
 

	
 
(defun wg-all-buf-uids (&optional session buffer-list)
 
  "Return the union of `wg-session-all-buf-uids' and `wg-buffer-list-all-uids'."
 
  (cl-union (wg-session-all-buf-uids session)
 
         (wg-buffer-list-all-uids buffer-list)
 
         :test 'string=))
 

	
 
(defun wg-gc-bufs ()
 
  "gc bufs from `wg-buf-list' that are no longer needed."
 
  (let ((all-buf-uids (wg-all-buf-uids)))
 
    (wg-asetf (wg-buf-list)
 
              (cl-remove-if-not (lambda (uid) (member uid all-buf-uids)) it
 
                             :key 'wg-buf-uid))))
 
                                :key 'wg-buf-uid))))
 

	
 

	
 
;; FIXME: Duplicate buf names probably shouldn't be allowed.  An unrelated error
 
;; causes two *scratch* buffers to be present, triggering the "uids don't match"
 
;; error.  Write something to remove bufs with duplicate names.
 

	
 

	
 
(defun wg-perform-session-maintenance ()
 
  "Perform various maintenance operations on the current Workgroups session."
 
  (wg-update-current-workgroup-working-wconfig)
 
  (wg-update-all-base-wconfigs)
 
  (wg-gc-bufs)
 
  (wg-gc-buf-uids)
 
  (wg-update-buf-list))
 

	
 

	
 
;; session consistency testing
 

	
 
(defun wg-session-uids-consistent-p ()
 
  "Return t if there are no duplicate bufs or buf uids in the wrong places,
 
nil otherwise."
 
  (and (cl-every (lambda (wg)
 
                (not (wg-dups-p (wg-workgroup-associated-buf-uids wg)
 
                                :test 'string=)))
src/workgroups-pickel.el
Show inline comments
 
@@ -321,58 +321,58 @@
 
     (wg-pickel-deserialize-links
 
      serial-links
 
      (wg-pickel-deserialize-objects serial-objects)))))
 

	
 
(defun wg-unpickel-file (file)
 
  "`unpickel' an object directly from FILE."
 
  (wg-unpickel (wg-lisp-object-from-file file)))
 

	
 
(defun wg-unpickel-string (str)
 
  "`unpickel' and object directly from STR."
 
  (wg-unpickel (read str)))
 

	
 

	
 

	
 

	
 

	
 
;;; parameter pickeling
 

	
 
  (defun wg-pickel-workgroup-parameters (workgroup)
 
    "If WORKGROUP's parameters are non-nil, return a copy of
 
WORKGROUP after pickeling its parameters. Otherwise return
 
WORKGROUP."
 
    (if (not (wg-workgroup-parameters workgroup)) workgroup
 
      (let ((copy (wg-copy-workgroup workgroup)))
 
        (wg-asetf (wg-workgroup-parameters copy) (wg-pickel copy))
 
        (wg-asetf (wg-workgroup-parameters copy) (wg-pickel it))
 
        copy)))
 

	
 
  (defun wg-unpickel-workgroup-parameters (workgroup)
 
    "If WORKGROUP's parameters are non-nil, return a copy of
 
WORKGROUP after unpickeling its parameters. Otherwise return
 
WORKGROUP."
 
    (if (not (wg-workgroup-parameters workgroup)) workgroup
 
      (let ((copy (wg-copy-workgroup workgroup)))
 
        (wg-asetf (wg-workgroup-parameters copy) (wg-unpickel copy))
 
        (wg-asetf (wg-workgroup-parameters copy) (wg-unpickel it))
 
        copy)))
 

	
 
  (defun wg-pickel-all-session-parameters (session)
 
    "Return a copy of SESSION after pickeling its
 
parameters and the parameters of all its workgroups."
 
    (let ((copy (wg-copy-session session)))
 
      (when (wg-session-parameters copy)
 
        (wg-asetf (wg-session-parameters copy) (wg-pickel copy)))
 
        (wg-asetf (wg-session-parameters copy) (wg-pickel it)))
 
      (wg-asetf (wg-session-workgroup-list copy)
 
                (cl-mapcar 'wg-pickel-workgroup-parameters it))
 
      copy))
 

	
 
  (defun wg-unpickel-session-parameters (session)
 
    "Return a copy of SESSION after unpickeling its
 
parameters and the parameters of all its workgroups."
 
    (let ((copy (wg-copy-session session)))
 
      (when (wg-session-parameters copy)
 
        (wg-asetf (wg-session-parameters copy) (wg-unpickel copy)))
 
        (wg-asetf (wg-session-parameters copy) (wg-unpickel it)))
 
      (wg-asetf (wg-session-workgroup-list copy)
 
                (cl-mapcar 'wg-unpickel-workgroup-parameters it))
 
      copy))
 

	
 
(provide 'workgroups-pickel)
 
;;; workgroups-pickel.el ends here
src/workgroups-specialbufs.el
Show inline comments
 
@@ -91,50 +91,50 @@ You can get these commands using `wg-get-org-agenda-view-commands'."
 
                               (org-agenda-list)
 
                               (wg-awhen (get-buffer org-agenda-buffer-name)
 
                                 (set-buffer it)
 
                                 (wg-run-agenda-cmd vars))
 
                               ))))
 

	
 
;; eshell
 
(wg-support 'eshell-mode 'esh-mode
 
            '((deserialize . (lambda (buffer vars)
 
                               (prog1 (eshell t)
 
                                 (rename-buffer (wg-buf-name buffer) t))))))
 

	
 
;; term-mode
 
;;
 
;; This should work for `ansi-term's, too, as there doesn't seem to
 
;; be any difference between the two except how the name of the
 
;; buffer is generated.
 
;;
 
(wg-support 'term-mode 'term
 
            `((serialize . ,(lambda (buffer)
 
                              (if (get-buffer-process buffer)
 
                                  (wg-last1 (process-command (get-buffer-process buffer)))
 
                                "/bin/bash")))
 
              (deserialize . ,(lambda (buffer vars)
 
                                (cl-flet ((term-window-width () 80)
 
                                          (window-height () 24))
 
                                (cl-labels ((term-window-width () 80)
 
                                            (window-height () 24))
 
                                  (prog1 (term vars)
 
                                    (rename-buffer (wg-buf-name buffer) t)))))))
 

	
 
;; Python
 
(wg-support 'inferior-python-mode 'python
 
            `((save . (python-shell-interpreter python-shell-interpreter-args))
 
              (deserialize . ,(lambda (buffer vars)
 
                                (wg-dbind (pythoncmd pythonargs) vars
 
                                  (save-window-excursion
 
                                    (run-python (concat pythoncmd " " pythonargs)))
 
                                  (wg-awhen (get-buffer (process-buffer (python-shell-get-or-create-process)))
 
                                    (set-buffer it)
 
                                    (switch-to-buffer (process-buffer (python-shell-get-or-create-process)))
 
                                    (goto-char (point-max)))
 
                                  )))))
 

	
 
;; Sage shell
 
(wg-support 'inferior-sage-mode 'sage-mode
 
            `((deserialize . ,(lambda (buffer vars)
 
                                (save-window-excursion
 
                                  (if (boundp' sage-command)
 
                                      (run-sage t sage-command t)))
 
                                (if (boundp 'sage-buffer)
 
                                    (wg-awhen (and
src/workgroups-utils-basic.el
Show inline comments
 
@@ -201,49 +201,49 @@ Return M when the difference between N and M is less than STEP."
 
  "Return t when NUM is within bounds LO and HI.
 
HI-INCLUSIVE non-nil means the HI bound is inclusive."
 
  (and (>= num lo) (if hi-inclusive (<= num hi) (< num hi))))
 

	
 
(defun wg-int-to-b36-one-digit (i)
 
  "Return a character in 0..9 or A..Z from I, and integer 0<=I<32.
 
Cribbed from `org-id-int-to-b36-one-digit'."
 
  (cond ((not (wg-within i 0 36))
 
         (error "%s out of range" i))
 
        ((< i 10) (+ ?0 i))
 
        ((< i 36) (+ ?A i -10))))
 

	
 
(defun wg-b36-to-int-one-digit (i)
 
  "Turn a character 0..9, A..Z, a..z into a number 0..61.
 
The input I may be a character, or a single-letter string.
 
Cribbed from `org-id-b36-to-int-one-digit'."
 
  (and (stringp i) (setq i (string-to-char i)))
 
  (cond ((and (>= i ?0) (<= i ?9)) (- i ?0))
 
        ((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10))
 
        (t (error "Invalid b36 character"))))
 

	
 
(defun wg-int-to-b36 (i &optional length)
 
  "Return a base 36 string from I."
 
  (let ((base 36) b36)
 
    (cl-flet ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36)
 
    (cl-labels ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36)
 
                         (setq i (/ i base))))
 
      (add-digit)
 
      (while (> i 0) (add-digit))
 
      (setq b36 (cl-map 'string 'identity b36))
 
      (if (not length) b36
 
        (concat (make-string (max 0 (- length (length b36))) ?0) b36)))))
 

	
 
(defun wg-b36-to-int (str)
 
  "Convert STR, a base-36 string, into the corresponding integer.
 
Cribbed from `org-id-b36-to-int'."
 
  (let ((result 0))
 
    (mapc (lambda (i)
 
            (setq result (+ (* result 36)
 
                            (wg-b36-to-int-one-digit i))))
 
          str)
 
    result))
 

	
 

	
 

	
 
;;; lists
 

	
 
(defmacro wg-removef-p (item seq-place &rest keys)
 
  "If ITEM is a `member*' of SEQ-PLACE, remove it from SEQ-PLACE and return t.
 
Otherwise return nil.  KEYS can be any keywords accepted by `remove*'."
 
@@ -493,49 +493,49 @@ BUFFER-LIST should contain buffer objects and/or buffer names."
 
  (string-match (concat "^" (regexp-quote (expand-file-name root-path)))
 
                (expand-file-name file-path)))
 

	
 

	
 

	
 
;;; frames
 

	
 
(defun wg-cyclic-nth-from-frame (&optional n frame)
 
  "Return the frame N places away from FRAME in `frame-list' cyclically.
 
N defaults to 1, and FRAME defaults to `selected-frame'."
 
  (wg-cyclic-nth-from-elt
 
   (or frame (selected-frame)) (frame-list) (or n 1)))
 

	
 

	
 

	
 
;;; namespace-prefixed defstruct
 

	
 
(defmacro wg-defstruct (prefix name-form &rest slot-defs)
 
  "`defstruct' wrapper that namespace-prefixes all generated functions.
 
Note: this doesn't yet work with :conc-name, and possibly other
 
options."
 
  (declare (indent 2))
 
  (let* ((name (if (consp name-form) (car name-form) name-form))
 
         (prefixed-name (wg-symcat prefix "-" name)))
 
    (cl-flet ((rebind (opstr)
 
    (cl-labels ((rebind (opstr)
 
                      (let ((oldfnsym (wg-symcat opstr "-" prefix "-" name)))
 
                        `((fset ',(wg-symcat prefix "-" opstr "-" name)
 
                                (symbol-function ',oldfnsym))
 
                          (fmakunbound ',oldfnsym)))))
 
      ;; `eval-and-compile' gets rid of byte-comp warnings ("function `foo' not
 
      ;; known to be defined").  We can accomplish this with `declare-function'
 
      ;; too, but it annoyingly requires inclusion of the function's arglist,
 
      ;; which gets ugly.
 
      `(eval-and-compile
 
         (cl-defstruct ,(if (symbolp name-form) prefixed-name
 
                       `(,prefixed-name ,@(cdr name-form)))
 
           ,@slot-defs)
 
         ,@(rebind "make")
 
         ,@(rebind "copy")
 
         ',prefixed-name))))
 

	
 
(defmacro wg-with-slots (obj slot-bindings &rest body)
 
  "Bind OBJ's slot values to symbols in BINDS, then eval BODY.
 
The car of each element of SLOT-BINDINGS is the bound symbol, and
 
the cadr as the accessor function."
 
  (declare (indent 2))
 
  (wg-with-gensyms (objsym)
 
    `(let* ((,objsym ,obj)
 
            ,@(wg-docar (slot slot-bindings)
 
@@ -551,49 +551,49 @@ the cadr as the accessor function."
 
  (zerop (minibuffer-depth)))
 

	
 
(defun wg-minibuffer-active-p ()
 
  "Return t when `minibuffer-depth' does not return zero, nil otherwise."
 
  (not (wg-minibuffer-inactive-p)))
 

	
 
(defun wg-fill-keymap (keymap &rest binds)
 
  "Return KEYMAP after defining in it all keybindings in BINDS."
 
  (while binds
 
    (define-key keymap (car binds) (cadr binds))
 
    (setq binds (cddr binds)))
 
  keymap)
 

	
 
(defun wg-add-or-remove-hooks (remove &rest pairs)
 
  "Add FUNCTION to or remove it from HOOK, depending on REMOVE."
 
  (dolist (pair (wg-partition pairs 2))
 
    (funcall (if remove 'remove-hook 'add-hook)
 
             (car pair) (cadr pair))))
 

	
 

	
 
(defun wg-read-object (prompt test warning &optional initial-contents keymap
 
                              read hist default-value inherit-input-method)
 
  "PROMPT for an object that satisfies TEST, WARNING if necessary.
 
ARGS are `read-from-minibuffer's args, after PROMPT."
 
  (cl-flet ((read () (read-from-minibuffer
 
  (cl-labels ((read () (read-from-minibuffer
 
                      prompt initial-contents keymap read hist
 
                      default-value inherit-input-method)))
 
    (let ((obj (read)))
 
      (when (and (equal obj "") default-value) (setq obj default-value))
 
      (while (not (funcall test obj))
 
        (message warning)
 
        (sit-for wg-minibuffer-message-timeout)
 
        (setq obj (read)))
 
      obj)))
 

	
 
(defvar wg-readable-types
 
  '(integer float cons symbol vector string char-table bool-vector)
 
  "List of types with readable printed representations.")
 

	
 
(defun wg-is-readable-p (obj)
 
  "Return non-nil if OBJ's printed representation is readable."
 
  (memq (type-of obj) wg-readable-types))
 

	
 
(defun wg-take-until-unreadable (list)
 
  "Return a new list of elements of LIST up to the first unreadable element."
 
  (wg-take-until-fail 'wg-is-readable-p list))
 

	
 
(defun wg-add-face (facekey string)
 
  "Return a copy of STRING fontified according to FACEKEY.
0 comments (0 inline, 0 general)