Skip to content

Instantly share code, notes, and snippets.

@wdkrnls
Created November 11, 2017 12:44
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save wdkrnls/2100f303c97dd9aba396e11897bb90f3 to your computer and use it in GitHub Desktop.
hlwm.el: control herbstluftwm from emacs
;;;; 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)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment