New jump-or-exec.jl (including cycle-or-exec)

[Teika Kazura <teika lavabit com>]

Hi. Let me send a new version of cycle-or-exec, put in
jump-or-exec.jl. This version works, but it's not yet to be
commited. Let's see how and why;

1. Inline doc for cycle-or-exec is added. But that's all.
2. 'class' arg of cycle-or-exec is changed from boolean to string,
so that you can match both name and class.
Filter predicates are unified, matching both name and class.

I don't think it's common to match both name and class, but it doesn't
hurt, and the new grammar looks better.

3 In cycle-or-exec, class match is done against "Class/instance" style.
jump-or-exec isn't changed yet, just to be cautious in changing shipped
API.

Todo ideas:
1. Apply changes to jump-or-exec, too. (And apologize the change in
the news.)

2. Allow key binding at once: 
(jump-or-exec/cycle-or-exec ...args... global-keymap "W-F10")

3. This is not in jump-or-exec.jl, but write a wrapper for window
cycling to allow temporary overriding of cycling custom options.
Suppose for example, you get a cycle-or-exec of emacs windows.
For other cyclings, you don't want to go to other viewports, but
with this wrapper, you can modify that behavior for that command only.

It's good to know that when you bind a closure to a key, then
it doesn't appear in the configurator, and it isn't saved into
~/.sawfish/custom. Thus 1. It doesn't cause any mess. 2. You have
to bind it every time from satfishrc.
 I guess this check is done by 'validp' in cfg.widgets.keymap, but I
don't know why it's deleted when you run configurator say for 'focus'
group only. Maybe check is done for all customization groups?

# After all, 'intern' is necessary as Christoph Ruegge did.

Teika (Teika kazura)

;;; jump-or-exec.jl --- flexible application shortcut keys (v0.2)

;; Copyright (C) 2002 Damien Elmes <resolve repose cx>
;; Copyright (C) 2009 Jeremy Hankins

;; This file is part of sawfish.

;; sawfish is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; sawfish is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with sawfish; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Description

;; These commands focus a given window, or when it's absent,
;; launches an application.

;; For usage, see comments at each command, jump-or-exec and
;; cycle-or-exec
;;

(define-structure sawfish.wm.commands.jump-or-exec

    (export jump-or-exec
            cycle-or-exec)

    (open rep
          rep.system
          rep.regexp
          sawfish.wm.misc
          sawfish.wm.windows
          sawfish.wm.util.display-window
          sawfish.wm.commands
          sawfish.wm.commands.x-cycle)

;;; jump-or-exec

  ;; NOTE: the `t' tells jump-or-exec to match on WM_CLASS
  ;; ( bind-keys global-keymap "W-F2"
  ;;   '( jump-or-exec "Gnome-run-dialog" "gnome-run-dialog" t ) )
  ;;
  ;; NOTE: a missing `t' or a `nil' (the latter is required if making
  ;;       use of the `onfocused' arguement) tells jump-or-exec to
  ;;       match on WM_NAME
  ;; ( bind-keys global-keymap "W-F10"
  ;;   '( jump-or-exec "Geany" "geany" nil ) )

  (define (jump-or-exec re prog #!optional class onfocused)
    "Jump to a window matched by re, or start program otherwise."
    (catch 'return
      (let ((wind (if class
                    (get-window-by-class-re re)
                    (get-window-by-name-re re))))
        (if (functionp onfocused) ; check if already focused
            (let ((curwin (input-focus)))
              (if curwin
                  (if (string-match re (window-name curwin))
                      (progn
                        (funcall onfocused wind)
                        (throw 'return))))))
        (if (windowp wind)
            (display-window wind)
          (if (functionp prog)
                (funcall prog)
              (system (concat prog "&")))))))

  (define-command 'jump-or-exec jump-or-exec #:class 'default)

;;; Cycle or exec

  ;; Internal helpers
  (define (filter name class)
    "Return a predicate to match windows."
    (lambda (w)
      (and (window-in-cycle-p w)
           (if (stringp name)
               (string-match name (window-name w))
             t)
           (if (stringp class)
               (string-match class (window-class w 'configurator))
             t))))

  (define (cycle-or-exec-backend pred prog)
    "Create a selector for define-cycle-command to run prog if there are no matching windows."
    (lambda ()
      (let ((windows (filter-windows pred)))
        (unless windows
          (when prog
            (if (functionp prog)
              (funcall prog)
              (system (concat prog "&")))))
        windows)))

  ;; Usage:
  ;;
  ;; name: Window name, or nil.
  ;; prog: When none matches, this is invoked. If a string, then invoke
  ;;       that shell command. If a lisp function, call it.
  ;; class: Window class, match against the form "Class/instance", or nil.
  ;; binding-name: name of the generated key command. Say if it's "grd",
  ;;       then it will create cycle-grd and cycle-grd-backwards.  If
  ;;       omitted, prog is referred, whether string or function.
  ;;
  ;; Example:
  ;;  ( cycle-or-exec "gnome-run-dialog" nil "Gnome-run-dialog" "grd" ) )
  ;;  ( bind-keys global-keymap "W-F2" cycle-grd)
  ;;
  ;;  ( cycle-or-exec "geany" "Geany" nil "ide" )
  ;;  ( bind-keys global-keymap "W-F10" cycle-ide)
  ;;

  (define (cycle-or-exec prog name #!optional class binding-name
                         keymap forward-key backward-key)
    (when (not (or name class))
      (error "Bad argument: to cycle-or-exec, name or class should be passed."))
    (let (forward-name backward-name)
      (unless binding-name
        (if (stringp prog)
            (setq binding-name prog)
          (setq binding-name (closure-name prog))))
      (setq forward-name (concat "cycle-" binding-name))
      (setq backward-name (concat forward-name "-backwards"))
      (define-cycle-command-pair
        (intern forward-name) (intern backward-name)
        (cycle-or-exec-backend (filter name class) prog))))
  )