src/clfswm-query.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Query utility
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  29 (defparameter *query-window* nil)
  30 (defparameter *query-font* nil)
  31 (defparameter *query-gc* nil)
  32
  33 (defparameter *query-history* nil)
  34
  35 (defparameter *query-message* nil)
  36 (defparameter *query-string* nil)
  37 (defparameter *query-pos* nil)
  38 (defparameter *query-return* nil)
  39
  40
  41
  42 (defun query-show-paren (orig-string pos)
  43   "Replace matching parentheses with brackets"
  44   (let ((string (copy-seq orig-string)))
  45     (labels ((have-to-find-right? ()
  46                (and (< pos (length string)) (char= (aref string pos) #\()))
  47              (have-to-find-left? ()
  48                (and (> (1- pos) 0) (char= (aref string (1- pos)) #\))))
  49              (pos-right ()
  50                (loop :for p :from (1+ pos) :below (length string)
  51                   :with level = 1   :for c = (aref string p)
  52                   :do (when (char= c #\() (incf level))
  53                   (when (char= c #\)) (decf level))
  54                   (when (= level 0) (return p))))
  55              (pos-left ()
  56                (loop :for p :from (- pos 2) :downto 0
  57                   :with level = 1   :for c = (aref string p)
  58                   :do (when (char= c #\() (decf level))
  59                   (when (char= c #\)) (incf level))
  60                   (when (= level 0) (return p)))))
  61       (when (have-to-find-right?)
  62         (let ((p (pos-right)))
  63           (when p (setf (aref string p) #\]))))
  64       (when (have-to-find-left?)
  65         (let ((p (pos-left)))
  66           (when p (setf (aref string p) #\[))))
  67       string)))
  68
  69
  70 (defun clear-query-history ()
  71   "Clear the query-string history"
  72   (setf *query-history* nil))
  73
  74
  75
  76 (defun leave-query-mode (&optional (return :Escape))
  77   "Leave the query mode"
  78   (setf *query-return* return)
  79   (throw 'exit-query-loop nil))
  80
  81
  82 (defun leave-query-mode-valid ()
  83   (leave-query-mode :Return))
  84
  85 (defun leave-query-mode-complet ()
  86   (leave-query-mode :Complet))
  87
  88 (add-hook *binding-hook* 'init-*query-keys*)
  89
  90
  91 (defun query-add-cursor (string)
  92   (concatenate 'string (subseq string 0 *query-pos*) "|" (subseq string *query-pos*)))
  93
  94 (defun query-print-string ()
  95   (clear-pixmap-buffer *query-window* *query-gc*)
  96   (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*))
  97   (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) *query-message*)
  98   (when (< *query-pos* 0)
  99     (setf *query-pos* 0))
 100   (when (> *query-pos* (length *query-string*))
 101     (setf *query-pos* (length *query-string*)))
 102   (xlib:draw-glyphs *pixmap-buffer* *query-gc*
 103                     10
 104                     (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 5)
 105                     (query-add-cursor (query-show-paren *query-string* *query-pos*)))
 106   (copy-pixmap-buffer *query-window* *query-gc*))
 107
 108
 109
 110 (defun query-enter-function ()
 111   (setf *query-font* (xlib:open-font *display* *query-font-string*))
 112   (let ((width (- (xlib:screen-width *screen*) 2))
 113         (height (* 3 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*)))))
 114     (with-placement (*query-mode-placement* x y width height)
 115       (setf *query-window* (xlib:create-window :parent *root*
 116                                                :x x :y y
 117                                                :width width
 118                                                :height height
 119                                                :background (get-color *query-background*)
 120                                                :border-width 1
 121                                                :border (get-color *query-border*)
 122                                                :colormap (xlib:screen-default-colormap *screen*)
 123                                                :event-mask '(:exposure :key-press))
 124             *query-gc* (xlib:create-gcontext :drawable *query-window*
 125                                              :foreground (get-color *query-foreground*)
 126                                              :background (get-color *query-background*)
 127                                              :font *query-font*
 128                                              :line-style :solid))
 129       (map-window *query-window*)
 130       (query-print-string)
 131       (wait-no-key-or-button-press))))
 132
 133
 134
 135 (defun query-leave-function ()
 136   (xlib:destroy-window *query-window*)
 137   (xlib:close-font *query-font*)
 138   (wait-no-key-or-button-press))
 139
 140 (defun query-loop-function ()
 141   (raise-window *query-window*))
 142
 143
 144
 145 (labels ((generic-backspace (del-pos)
 146            (when (>= del-pos 0)
 147              (setf *query-string* (concatenate 'string
 148                                                (subseq *query-string* 0 del-pos)
 149                                                (subseq *query-string* *query-pos*))
 150                    *query-pos* del-pos))))
 151   (defun query-backspace ()
 152     "Delete a character backward"
 153     (generic-backspace (1- *query-pos*)))
 154
 155   (defun query-backspace-word ()
 156     "Delete a word backward"
 157     (generic-backspace (or (position #\Space *query-string* :from-end t :end *query-pos*) 0))))
 158
 159
 160 (labels ((generic-delete (del-pos)
 161            (when (<= del-pos (length *query-string*))
 162              (setf *query-string* (concatenate 'string
 163                                               (subseq *query-string* 0 *query-pos*)
 164                                               (subseq *query-string* del-pos))))))
 165   (defun query-delete ()
 166     "Delete a character forward"
 167     (generic-delete (1+ *query-pos*)))
 168
 169   (defun query-delete-word ()
 170     "Delete a word forward"
 171     (generic-delete (1+ (or (position #\Space *query-string* :start *query-pos*)
 172                             (1- (length *query-string*)))))))
 173
 174
 175
 176 (defun query-home ()
 177   "Move cursor to line begining"
 178   (setf *query-pos* 0))
 179
 180 (defun query-end ()
 181   "Move cursor to line end"
 182   (setf *query-pos* (length *query-string*)))
 183
 184
 185 (defun query-left ()
 186   "Move cursor to left"
 187   (when (> *query-pos* 0)
 188     (setf *query-pos* (1- *query-pos*))))
 189
 190 (defun query-left-word ()
 191   "Move cursor to left word"
 192   (when (> *query-pos* 0)
 193     (setf *query-pos* (let ((p (position #\Space *query-string*
 194                                          :end (min (1- *query-pos*) (length *query-string*))
 195                                          :from-end t)))
 196                         (if p p 0)))))
 197
 198 (defun query-right ()
 199   "Move cursor to right"
 200   (when (< *query-pos* (length *query-string*))
 201     (setf *query-pos* (1+ *query-pos*))))
 202
 203 (defun query-right-word ()
 204   "Move cursor to right word"
 205   (when (< *query-pos* (length *query-string*))
 206     (setf *query-pos* (let ((p (position #\Space *query-string*
 207                                          :start (min (1+ *query-pos*) (length *query-string*)))))
 208                         (if p p (length *query-string*))))))
 209
 210 (defun query-previous-history ()
 211   "Circulate backward in history"
 212   (setf *query-string* (first *query-history*)
 213         *query-pos* (length *query-string*)
 214         *query-history* (rotate-list *query-history*)))
 215
 216
 217 (defun query-next-history ()
 218   "Circulate forward in history"
 219   (setf *query-string* (first *query-history*)
 220         *query-pos* (length *query-string*)
 221         *query-history* (anti-rotate-list *query-history*)))
 222
 223
 224
 225 (defun query-delete-eof ()
 226   "Delete the end of the line"
 227   (setf *query-string* (subseq *query-string* 0 *query-pos*)))
 228
 229
 230 (add-hook *binding-hook* 'set-default-query-keys)
 231
 232 (defun set-default-query-keys ()
 233   (define-query-key ("Return") 'leave-query-mode-valid)
 234   (define-query-key ("Escape") 'leave-query-mode)
 235   (define-query-key ("g" :control) 'leave-query-mode)
 236   (define-query-key ("Tab") 'leave-query-mode-complet)
 237   (define-query-key ("BackSpace") 'query-backspace)
 238   (define-query-key ("BackSpace" :control) 'query-backspace-word)
 239   (define-query-key ("Delete") 'query-delete)
 240   (define-query-key ("Delete" :control) 'query-delete-word)
 241   (define-query-key ("Home") 'query-home)
 242   (define-query-key ("End") 'query-end)
 243   (define-query-key ("Left") 'query-left)
 244   (define-query-key ("Left" :control) 'query-left-word)
 245   (define-query-key ("Right") 'query-right)
 246   (define-query-key ("Right" :control) 'query-right-word)
 247   (define-query-key ("Up") 'query-previous-history)
 248   (define-query-key ("Down") 'query-next-history)
 249   (define-query-key ("k" :control) 'query-delete-eof))
 250
 251
 252
 253 (defun add-in-query-string (code state)
 254   (let* ((modifiers (state->modifiers state))
 255          (keysym (keycode->keysym code modifiers))
 256          (char (xlib:keysym->character *display* keysym)))
 257     (when (and (characterp char) (standard-char-p char))
 258       (setf *query-string* (concatenate 'string
 259                                         (when (<= *query-pos* (length *query-string*))
 260                                           (subseq *query-string* 0 *query-pos*))
 261                                         (string char)
 262                                         (when (< *query-pos* (length *query-string*))
 263                                           (subseq *query-string* *query-pos*))))
 264       (incf *query-pos*))))
 265
 266
 267
 268 (define-handler query-mode :key-press (code state)
 269   (unless (funcall-key-from-code *query-keys* code state)
 270     (add-in-query-string code state))
 271   (query-print-string))
 272
 273
 274
 275 (defun  query-string (message &optional (default ""))
 276   "Query a string from the keyboard. Display msg as prompt"
 277   (let ((grab-keyboard-p (xgrab-keyboard-p))
 278         (grab-pointer-p (xgrab-pointer-p)))
 279     (setf *query-message* message
 280           *query-string* default
 281           *query-pos* (length default))
 282     (xgrab-pointer *root* 92 93)
 283     (unless grab-keyboard-p
 284       (ungrab-main-keys)
 285       (xgrab-keyboard *root*))
 286     (generic-mode 'query-mode 'exit-query-loop
 287                   :enter-function #'query-enter-function
 288                   :loop-function #'query-loop-function
 289                   :leave-function #'query-leave-function
 290                   :original-mode '(main-mode))
 291     (unless grab-keyboard-p
 292       (xungrab-keyboard)
 293       (grab-main-keys))
 294     (if grab-pointer-p
 295         (xgrab-pointer *root* 66 67)
 296         (xungrab-pointer)))
 297   (when (member *query-return* '(:Return :Complet))
 298     (pushnew default *query-history* :test #'equal)
 299     (push *query-string* *query-history*))
 300   (values *query-string*
 301           *query-return*))
 302
 303
 304
 305 (defun query-number (msg &optional (default 0))
 306   "Query a number from the query input"
 307   (parse-integer (or (query-string msg (format nil "~A" default)) "") :junk-allowed t))