hlwm.el: control herbstluftwm from emacs

hlwm.el

;;;; HLWM convience tools
;; author: Kyle Andrews
;; license: GPL V3 or later


(defun bash-path ()
  "Return all the executables in the path according to bash.

This does not work as well as dmenu-path since it includes bash
reserved words in the result."
  (s-split-words  (shell-command-to-string "compgen -c | sort | uniq")))


(defun dmenu-path ()
  "Return the executables the script dmenu_path identifies as a
list of strings.

This is useful as a helm source."
  (-drop 18 (s-split-words (shell-command-to-string "dmenu_path"))))

(defun k/file-menu ()
  "First attempt at hlwm/exec-program.

Deprecated."
  (let ((helm-full-frame t)
        (helm-candidate-number-limit nil)
        (pth (k/dmenu-path)))
    (helm :sources
          (list
           (cons 'name "Programs")
           (cons 'candidates
                 (-map (lambda (x) (cons x x)) pth))
           )
          :fuzzy-match t)))


(defun hlwm/run-executable (executable)
  "Function to run an executable independent of emacs.

This is used for hlwm/run-executable."
  (let ((shell-command-switch "-c"))
    (call-process executable nil 0)))


(defvar helm-source-dmenu-path-executables
  '((name . "Executables")
    (candidates . dmenu-path)
    (action . (("Run Executable" . hlwm/run-executable))))
  "The source for hlwm/run-executable helm function.")


(defun hlwm/exec-program ()
  "Execute a program."

  (let ((helm-full-frame t)
	(layout (hlwm/layout)))
        (hlwm/client "set_layout max")
	(helm :sources '(helm-source-dmenu-path-executables)
	      :fuzzy-match t)
	(hlwm/client (format "set_layout %s" layout))))


;; (popup-tip "A popup tip."
;; 	   :point (point)
;; 	   :around t
;; 	   :height 3
;; 	   :margin t)


(defun describe-function-in-popup ()
  "The function documentation in a popup."
  (interactive)
  (let* ((thing (symbol-at-point))
	 (pop-up-frames nil)
	 (description (save-window-excursion
			(describe-function thing)
			(switch-to-buffer "*Help*")
			(buffer-string))))
    (popup-tip description
	       :point (point)
	       :around t
	       :height 30
	       :scroll-bar t
	       :margin t)))


(defun popup-show-buffer (buf)
  (let ((pop-up-frames nil))
    (popup-tip (buffer-))))


(defun hlwm/object-tree-popup ()
  "Show the current hlwm object tree in a buffer."
  (interactive)
  (let* ((shell-command-switch "-c")
	 (object-tree-string
	  (shell-command-to-string "herbstclient object_tree")))
    (popup-tip object-tree-string
	       :point (point-at-bol)
	       :around t
	       :height 30
	       :scroll-bar t
	       :margin t)))


(defun hlwm/insert-object-tree ()
  "Insert the object tree at point."
  (let ((shell-command-switch "-c"))
    (insert (concat (newline) (shell-command-to-string "herbstclient object_tree")))))


(defun hlwm/client (command)
  "Elisp wrapper arround herbstclient."
  (let ((shell-command-switch "-c"))
    (s-chomp (shell-command-to-string (format "herbstclient %s" command)))))


(defun hlwm/tag-status-raw ()
  "Get the status of tags as output by herbstclient."
  (-butlast (rest (s-split "\t" (hlwm/client "tag_status")))))


(defvar hlwm/tag-status-conditions
  '(("." . "empty")
    (":" . "occupied")
    ("-" . "other monitor (not focused)")
    ("+" . "other monitor (focused)")
    ("#" . "focused"))
  "These are code hlwm uses to indicate tag conditions.")


(defun hlwm/tag-status (&optional tag)
  "No idea what this is used for (but for the name)."
  (let ((status
	 (-map (lambda (tag)
		 (cons (substring tag 1)
		       (substring tag 0 1)))
	       (hlwm/tag-status-raw))))
    (if tag
	(cdr (assoc (cdr (assoc tag status)) hlwm/tag-status-conditions))
      status)))


(defun hlwm/list-client-winids ()
  "Get the X window ids for all the clients managed by hwlm."
  (-map #'s-chomp
	(-map #'s-trim
	      (--take-while
	       (< 0 (length it))
	       (rest (s-split "\n" (hlwm/client "attr clients")))))))


(defvar hlwm/client-properties
  (list "winid" "pid" "class" "tag" "instance" "fullscreen" "pseudotile" "urgent" "title")
  "X properties to tabulate for each client.")

(defvar hlwm/client-properties-all
  (list "winid" "pid" "class" "tag" "instance" "fullscreen" "pseudotile" "urgent" "title")
  "X properties to tabulate for each client. Exhaustive list.")

(defvar hlwm/client-properties-switch
  (list "winid" "pid" "class" "tag" "title")
  "X properties to tabulate for each client. Narrow list for switching.")

(defvar hlwm/client-properties-kill
  (list "winid" "pid" "class" "pseudotile" "urgent" "title")
  "X properties to tabulate for each client. Narrow list for killing.")


;; TODO: would be nice if you could just the defvar to use.
(defun hlwm/client-properties-entry (winid)
  "Find X properties for each win id."
  (-map (lambda (property)
	  (hlwm/client
	   (format "attr clients.%s.%s" winid property)))
	hlwm/client-properties))


(defun hlwm/client-switch-properties-entry (winid)
  "For example:  (hlwm/client-properties-entry \"0x1600001\")"
  (-map (lambda (property)
	  (hlwm/client
	   (format "attr clients.%s.%s" winid property)))
	hlwm/client-properties-switch))


;; TODO: this code duplication should be removed at some point.
(defun hlwm/list-clients (&optional tag)
  "List clients and properties. Optionally, by tag."
  (let* ((winids (hlwm/list-client-winids))
	 (data 
	  (cons hlwm/client-properties
		(-map #'hlwm/client-properties-entry winids))))
    (if tag
	(cons (car data)
	      (lt/match-filter (cdr data) 3 tag))
      data)))


(defun hlwm/list-clients-switch (&optional tag)
  "List clients and properties. Optionally by tag. Narrower."
  (let* ((winids (hlwm/list-client-winids))
	 (data 
	  (cons hlwm/client-properties-switch
		(-map #'hlwm/client-switch-properties-entry winids))))
    (if tag
	(cons (car data)
	      (lt/match-filter (cdr data) 3 tag))
    data)))


(defun hlwm/org-list-clients (&optional tag &rest ns)
  "Convience function for generate org mode tables of hlwm client
properties."
  (let* ((data (if tag
		   (hlwm/list-clients tag)
		 (hlwm/list-clients)))
	 (data-1 (if ns (lt/cbind-1 data ns) data)))
        (cons (first data-1) (cons 'hline (rest data-1)))))


(defun hlwm/tabulate-clients ()
  "Not really sure how this differs from list clients."
  (let ((clients (hlwm/list-clients)))
    (cons (car clients) (cons 'hline (cdr clients)))))


(defun hlwm/current-tag-old ()
  "Return the current tag."
  (let ((tag       
	 (first
	  (-filter (lambda (tag) (s-matches? "^#" tag))
		   (hlwm/tag-status)))))
    (substring tag 1)))


(defun hlwm/current-tag ()
  "Find the currently focused tag."
  (hlwm/client "attr clients.focus.tag"))


(defun hlwm/list-tags ()
  (let ((intermediate 
	 (rest (-map #'s-trim (s-split "\n" (hlwm/client "attr tags.by-name"))))))
    (--map (substring it 0 (1- (length it)))
	   (-take (- (length intermediate) 2)
		  intermediate))))


(defun hlwm/tag-name-p (name)
  (if (member name (hlwm/list-tags)) t nil))


(defun hlwm/remove-tag (tag)
  "Delete the requested tag."
  (cond ((not (hlwm/tag-name-p tag)) nil)
	((hlwm/tag-empty-p tag)
	 (hlwm/client (format "merge_tag %s" tag)))
	(t (message "*tag is not empty or is in use!*"))))


;; consider making a function so we can get move-tag working
(defvar helm-source-hlwm-tags
  '((name . "Tags")
    (candidates . hlwm/list-tags)
    (action . (("Switch to Tag" . hlwm/use-tag)
	       ("Move to Tag" . hlwm/move-tag)
	       ("Delete Tag" . hlwm/remove-tag)
           ("Rename Tag" . hlwm/rename)))))


(defun hlwm/use-tag (tag)
  (if (hlwm/tag-name-p tag)
      (hlwm/client (format "use %s" tag))
    (progn (hlwm/client (format "add %s" tag))
	   (hlwm/use-tag tag))))


(defun hlwm/swap-tags (tag1 tag2)
  "Switch ordering of tags in the tag bar."
  nil
  )


(defun hlwm/move-tag (tag)
  "Move currently focused window/frame to TAG."
  (if (hlwm/tag-name-p tag)
      (hlwm/client (format "move %s" tag))
    (progn (hlwm/client (format "add %s" tag))
           (hlwm/move-tag tag))))


(defun hlwm/tag-empty-p (tag)
  "Test if the tag is empty."
  (string-equal (hlwm/tag-status tag) "empty"))


;; TODO: when called externally from Emacs, helm will not move windows
;; to tags because it does not know about the window.
(defun hlwm/helm-switch-tag-1 (client)
  (let ((minibuffer-completion-confirm 'confirm))
    (helm :sources '(helm-source-hlwm-tags)
        :fuzzy-match t)))

(defun hlwm/layout ()
  (let ((shell-command-switch "-c"))
    (car
     (s-match
      "[a-z]+"
      (s-chomp
       (shell-command-to-string
	(format "herbstclient layout | grep FOCUS | cut -d':' -f1")))))))


(defun hlwm/helm-switch-tag ()
  (interactive)
  (let ((layout (hlwm/layout))
        (client (hlwm/client "attr clients.focus.winid"))
        (helm-full-frame t)
        (minibuffer-completion-confirm 'confirm))
    (hlwm/client "set_layout max")
    (hlwm/helm-switch-tag-1 client)
    (hlwm/client (format "set_layout %s" layout))))

(defun lt/table? (obj)
  (and (listp obj)
       (-all? (lambda (thing)
		(and (listp thing)
		     (-none? #'listp thing)))
	      obj)))

(defun lt/col (tbl N)
  "Return the column."
  (let* ((n (length (car tbl))))
    (if (< (- n) N 0) (setq N (+ n N)))
    (-map (lambda (row) (nth N row)) tbl)))

(defun lt/row (tbl N)
  (let ((n (length tbl)))
    (if (< (- n) N 0) (setq N (+ n N)))
    (nth N tbl)))

(defun lt/nth (N list)
  (let ((n (length list)))
    (if (< (- n) N 0) (setq N (+ n N)))
    (nth N list)))


(defun lt/rc (tbl R C)
  "Select data point by row R and column C."
  (lt/nth C (lt/row tbl R)))


(defun lt/header (tbl)
  "Return the first row of the table as header information."
  (car tbl))


(defun lt/data (tbl)
  "Return all but the first row of the table as data"
  (cdr tbl))


(defun lt/transpose (tbl)
  "Transpose the table."
  (let ((n (length (car tbl))))
    (loop for N below n collect (lt/col tbl N))))


(defun lt/cbind (tbl &rest Ns)
  "Join numerically specified columns together."
  (lt/transpose 
   (lt/rbind-1 (lt/transpose tbl) Ns)))


(defun lt/cbind-1 (tbl Ns)
  "Join numerically specified columns together.

Convenience function because I'm not sure what the idiomatic
solution to this problem is."
  (lt/transpose 
   (lt/rbind-1 (lt/transpose tbl) Ns)))


(defun lt/rbind (tbl &rest Ns)
  "Join numerically specified rows together."
  (-map (lambda (m) (lt/row tbl m)) Ns))


(defun lt/rbind-1 (tbl Ns)
  "Join numerically specified rows together.

Convenience function because I'm not sure what the idiomatic
solution to this problem is."
  (-map (lambda (m) (lt/row tbl m)) Ns))


(defun lt/match-filter (tbl N match)
  "filter rows in TBL by searching for a MATCH in the numerically
specified column N."
  (-filter (lambda (row) (equal (lt/nth N row) match)) tbl))


(defun hlwm/clients ()
  "Returns the PIDs of the client windows.

Probably deprecated."
 (-map (lambda (client) (nth 1 client)) (rest (hlwm/list-clients))))


(defun hlwm/clients-switch ()
  "The same as hlwm/clients but with fewer columns.

Probably deprecated."
  (-map (lambda (client) (nth 4 client)) (rest (hlwm/list-clients-switch))))


(defun hlwm/helm-class-sources ()
  "Collect class information."
  (let* ((data (lt/cbind (rest (hlwm/list-clients)) 2 8 0))
	 (classes (-uniq (lt/col data 0))))
    (loop for class in classes collect
	  (list (cons 'name class)
		(cons 'candidates
		      (-map (lambda (win) (apply #'cons win))
			    (lt/cbind (lt/match-filter data 0 class) 1 2)))
		(cons 'action (list (cons "Jump to client" #'hlwm/jumpto)))))))


(defun hlwm/helm-class-sources-2 ()
  "Faster version of hlwm/helm-class-sources by cutting down on
  the list table processing."
  (let* ((data (lt/cbind (rest (hlwm/list-clients-switch)) 2 4 0))
	 (classes (-uniq (lt/col data 0))))
    (loop for class in classes collect
	  (list (cons 'name class)
		(cons 'candidates
		      (-map (lambda (win) (apply #'cons win))
			    (lt/cbind (lt/match-filter data 0 class) 1 2)))
		(cons 'action (list (cons "Jump to client" #'hlwm/jumpto)
                            (cons "Bring client here" #'hlwm/bring)))))))


(defun hlwm/helm-jumpto-client ()
  (interactive)
  (let ((layout (hlwm/layout))
        (sources (hlwm/helm-class-sources-2))
        (helm-full-frame t))
    (hlwm/client (format "set_layout max"))
    (helm :sources sources
	  :fuzzy-match t)
    (hlwm/client (format "set_layout %s" layout))))


(defun hlwm/jumpto (client)
  (hlwm/client (format "jumpto %s" client)))

(defun hlwm/bring (client)
  (hlwm/client (format "bring %s" client)))


(defvar helm-source-hlwm-clients
  '((name . "Clients")
    (candidates . hlwm/clients)
    (action . (("Jump to client" . hlwm/jumpto)))))


(defun hlwm/insert (command)
  (let ((shell-command-switch "-c"))
    (insert (concat (newline) (shell-command-to-string (format "herbstclient %s" command))))))


(defun hlwm/rename-tag (old new)
  (hlwm/client (format "rename %s %s" old new)))


(defun hlwm/rename (tag)
  (interactive "sRename tag: ")
  (let ((new (read-string "To: ")))
    (message (format "Renaming %s to %s." tag new))
    (hlwm/rename-tag tag new)))