stumpwm/utils.lisp @ 4f28fbfd7d63 default tip

(in-package :stumpwm-user)

(defun string-contains (needle string)
  (and (search needle string :test #'char=) t))

(defun string-grep (needle text &key first-only)
  (_ text
    (split-sequence:split-sequence #\newline _)
    (if first-only
      (find needle _ :test #'string-contains)
      (remove-if-not (alexandria:curry #'string-contains needle) _))))

(defun string-split (delimiters string)
  (split-sequence:split-sequence delimiters string
                                 :test (lambda (bag ch)
                                         (find ch bag :test #'char=))))

(defun run-and-echo-shell-command (command &rest args)
  (message command)
  (apply #'run-shell-command command args))


(defun mod+ (n increment modulo)
  (mod (+ n increment) modulo))


(defmacro defcached ((name &key seconds) &body body)
  (let ((seconds (coerce seconds 'double-float)))
    (with-gensyms (ttl next value)
      `(let ((,ttl ,seconds)
             (,next nil)
             (,value nil))
         (defun ,name ()
           (when (or (null ,next)
                     (>= (get-internal-real-time) ,next))
             (setf ,next (+ (get-internal-real-time)
                            (* internal-time-units-per-second ,ttl))
                   ,value (progn ,@body)))
           ,value)
         (defun ,(symb name '/uncache) ()
           (setf ,next nil ,value nil))))))


(defun current-frame ()
  (stumpwm::tile-group-current-frame (current-group)))


(defun keywordize (string)
  (_ string
    (string-trim (string #\newline) _)
    string-upcase
    (intern _ (find-package :keyword))))

(defparameter *host* (keywordize (machine-instance)))


(defmacro ehostcase (&body clauses)
  `(ecase *host* ,@clauses))

(defmacro hostcase (&body clauses)
  `(case *host* ,@clauses))


(defcommand speak (text)
    ((:string "Text: "))
  (message text)
  (run-shell-command (format nil "~~/src/dotfiles/bin/say '~A'" text)))


(defun seconds->hours (seconds)
  (/ seconds 60 60))

(defun hours->seconds (hours)
  (* hours 60 60))


(define-stumpwm-type :integer (input prompt)
  ;; Annoyingly, StumpWM's built-in :number type isn't actually number, but is
  ;; actually just integers.  Define a better-named type here.
  (when-let ((n (or (argument-pop input)
                    (read-one-line (current-screen) prompt))))
    (handler-case
        (parse-integer n)
      (parse-error (c)
        (declare (ignore c))
        (throw 'error "Integer required.")))))

(define-stumpwm-type :real (input prompt)
  (when-let ((n (or (argument-pop input)
                    (read-one-line (current-screen) prompt))))
    (handler-case
        (let ((result (parse-number:parse-number n)))
          (assert (typep result 'real))
          result)
      (error (c)
        (declare (ignore c))
        (throw 'error "Real required.")))))


(defun window-match-p (query window)
  "Return whether `window` matches `query`.

  `query` must be of the form `(query-type query-value)`.

  `query-type` must be one of `:title` or `:class`.

  `query-value` must either be a string (which must be matched exactly) or
  a PPCRE scanner.

  "
  (destructuring-bind (query-type query) query
    (let ((value (ecase query-type
                   (:title (window-title window))
                   (:class (window-class window)))))
      (etypecase query
        (string (string= query value))
        (function (ppcre:scan query value))))))

(defun all-windows ()
  "Return a fresh list of all windows on all screens.  Yes, all of them."
  (mapcan #'screen-windows *screen-list*))

(defun find-window (query)
  "Find and return the first window that matches `query` under `window-match-p`."
  (find-if (lambda (w) (window-match-p query w)) (all-windows)))

(defun find-windows (query)
  "Find and return a fresh list of all windows that match `query` under `window-match-p`."
  (remove-if-not (lambda (w) (window-match-p query w)) (all-windows)))

(defmacro when-let-window ((symbol title-query) &body body)
  `(when-let ((,symbol (find-window `(:title ,(ppcre:create-scanner ,title-query)))))
     ,@body))