Merge pull request #309 from PuercoPop/alexandria

Depend on Alexandria

.travis.yml

@@ -16,7 +16,7 @@ install:
     else
       curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh;
     fi
-  - cl -l clx -l cl-ppcre -e '(ql-util:without-prompting (ql:add-to-init-file))'
+  - cl -l alexandria -l clx -l cl-ppcre -e '(ql-util:without-prompting (ql:add-to-init-file))'
 
 before_script:
   - ./autogen.sh

command.lisp

@@ -120,32 +120,32 @@ when missing.
 Alternatively, instead of specifying nil for PROMPT or leaving it
 out, an element can just be the argument type."
   (check-type name (or symbol list))
-  (let ((docstring (if (stringp (first body))
-                     (first body)
-                     (warn (make-condition 'command-docstring-warning :command name))))
-        (body (if (stringp (first body))
-                  (cdr body) body))
-        (name (if (atom name)
-                  name
-                  (first name)))
-        (group (if (atom name)
-                   t
-                   (second name))))
-  `(progn
-     (defun ,name ,args
-       ,docstring
-       (let ((%interactivep% *interactivep*)
-             (*interactivep* nil))
-         (declare (ignorable %interactivep%))
-         (run-hook-with-args *pre-command-hook* ',name)
-         (multiple-value-prog1
-             (progn ,@body)
-           (run-hook-with-args *post-command-hook* ',name))))
-     (export ',name)
-     (setf (gethash ',name *command-hash*)
-           (make-command :name ',name
-                         :class ',group
-                         :args ',interactive-args)))))
+  (multiple-value-bind (body decls docstring) (parse-body body :documentation t)
+    (let ((name (if (atom name)
+                    name
+                    (first name)))
+          (group (if (atom name)
+                     t
+                     (second name))))
+      (unless docstring
+        (make-condition 'command-docstring-warning :command name))
+      `(progn
+         (defun ,name ,args
+           ,@(when docstring
+               (list docstring))
+           ,@decls
+           (let ((%interactivep% *interactivep*)
+                 (*interactivep* nil))
+             (declare (ignorable %interactivep%))
+             (run-hook-with-args *pre-command-hook* ',name)
+             (multiple-value-prog1
+                 (progn ,@body)
+               (run-hook-with-args *post-command-hook* ',name))))
+         (export ',name)
+         (setf (gethash ',name *command-hash*)
+               (make-command :name ',name
+                             :class ',group
+                             :args ',interactive-args))))))
 
 (defmacro define-stumpwm-command (name (&rest args) &body body)
   "Deprecated. use `defcommand' instead."
@@ -442,15 +442,14 @@ then describes the symbol."
 
 (define-stumpwm-type :frame (input prompt)
   (declare (ignore prompt))
-  (let ((arg (argument-pop input)))
-    (if arg
-        (or (find arg (group-frames (current-group))
-                  :key (lambda (f)
-                         (string (get-frame-number-translation f)))
-                  :test 'string=)
-            (throw 'error "Frame not found."))
-        (or (choose-frame-by-number (current-group))
-            (throw 'error :abort)))))
+  (if-let ((arg (argument-pop input)))
+    (or (find arg (group-frames (current-group))
+              :key (lambda (f)
+                     (string (get-frame-number-translation f)))
+              :test 'string=)
+        (throw 'error "Frame not found."))
+    (or (choose-frame-by-number (current-group))
+        (throw 'error :abort))))
 
 (define-stumpwm-type :shell (input prompt)
   (or (argument-pop-rest input)

events.lisp

@@ -34,10 +34,15 @@
 (defmacro define-stump-event-handler (event keys &body body)
   (let ((fn-name (gensym))
         (event-slots (gensym)))
-    `(labels ((,fn-name (&rest ,event-slots &key ,@keys &allow-other-keys)
-               (declare (ignore ,event-slots))
-               ,@body))
-      (setf (gethash ,event *event-fn-table*) #',fn-name))))
+    (multiple-value-bind (body declarations docstring)
+        (parse-body body :documentation t)
+        `(labels ((,fn-name (&rest ,event-slots &key ,@keys &allow-other-keys)
+                    (declare (ignore ,event-slots))
+                    ,@(when docstring
+                        (list docstring))
+                    ,@declarations
+                    ,@body))
+           (setf (gethash ,event *event-fn-table*) #',fn-name)))))
 
 ;;; Configure request
 

group.lisp

@@ -327,19 +327,17 @@ Groups are known as \"virtual desktops\" in the NETWM standard."
 (defun group-forward (current list)
   "Switch to the next non-hidden-group in the list, if one
 exists. Returns the new group."
-  (let ((ng (next-group current (non-hidden-groups list))))
-    (when ng
-      (switch-to-group ng)
-      ng)))
+  (when-let ((ng (next-group current (non-hidden-groups list))))
+    (switch-to-group ng)
+    ng))
 
 (defun group-forward-with-window (current list)
   "Switch to the next group in the list, if one exists, and moves the
 current window of the current group to the new one."
-  (let ((next (group-forward current list))
-        (win (group-current-window current)))
-    (when (and next win)
-      (move-window-to-group win next)
-      (really-raise-window win))))
+  (when-let ((next (group-forward current list))
+             (win (group-current-window current)))
+    (move-window-to-group win next)
+    (really-raise-window win)))
 
 (defcommand gnew (name) ((:string "Group Name: "))
   "Create a new group with the specified name. The new group becomes the
@@ -438,13 +436,12 @@ the default group formatting and window formatting, respectively."
 (defcommand grouplist (&optional (fmt *group-format*)) (:rest)
   "Allow the user to select a group from a list, like windowlist but
   for groups"
-  (let ((group (second (select-from-menu
-		(current-screen)
-		(mapcar (lambda (g)
-			  (list (format-expand *group-formatters* fmt g) g))
-			(screen-groups (current-screen)))))))
-    (when group
-      (switch-to-group group))))
+  (when-let ((group (second (select-from-menu
+                             (current-screen)
+                             (mapcar (lambda (g)
+                                       (list (format-expand *group-formatters* fmt g) g))
+                                     (screen-groups (current-screen)))))))
+    (switch-to-group group)))
 
 (defcommand gmove (to-group) ((:group "To Group: "))
 "Move the current window to the specified group."

package.lisp

@@ -18,7 +18,8 @@
 ;; <http://www.gnu.org/licenses/>.
 
 (defpackage :stumpwm
-  (:use :cl)
+  (:use :cl
+        #:alexandria)
   (:shadow #:yes-or-no-p #:y-or-n-p)
   (:export
    #:call-in-main-thread))

primitives.lisp

@@ -989,11 +989,6 @@ raise/map denial messages will be seen.")
                 deny-list)
        t)))
 
-(defun flatten (list)
-  "Flatten LIST"
-  (labels ( (mklist (x) (if (listp x) x (list x))) )
-    (mapcan #'(lambda (x) (if (atom x) (mklist x) (flatten x))) list)))
-
 (defun list-splice-replace (item list &rest replacements)
   "splice REPLACEMENTS into LIST where ITEM is, removing
 ITEM. Return the new list."

stumpwm.asd

@@ -12,7 +12,8 @@
   ;; :license "GNU General Public License"
   :description "A tiling, keyboard driven window manager" 
   :serial t
-  :depends-on (:cl-ppcre #-cmu :clx #+sbcl :sb-posix)
+  :depends-on (#:alexandria
+               :cl-ppcre #-cmu :clx #+sbcl :sb-posix)
   :components ((:file "package")
                (:file "primitives")
                (:file "workarounds")