src/clfswm-query.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Query utility
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2011 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* (list ""))
  34 (defparameter *query-complet-list* nil)
  35
  36 (defparameter *query-message* nil)
  37 (defparameter *query-string* nil)
  38 (defparameter *query-pos* nil)
  39 (defparameter *query-return* nil)
  40
  41
  42 (defun query-show-paren (orig-string pos dec)
  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              (draw-bloc (p &optional (color *query-parent-color*))
  62                (setf (xlib:gcontext-foreground *query-gc*) (get-color color))
  63                (xlib:draw-rectangle *pixmap-buffer* *query-gc*
  64                                     (+ 10 (* p (xlib:max-char-width *query-font*)) dec)
  65                                     (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*) 7)
  66                                     (xlib:max-char-width *query-font*)
  67                                     (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))
  68                                     t)))
  69       (cond ((have-to-find-left?) (let ((p (pos-left)))
  70                                     (if p
  71                                         (progn (draw-bloc p) (draw-bloc (1- pos)))
  72                                         (draw-bloc (1- pos) *query-parent-error-color*))))
  73             ((have-to-find-right?) (let ((p (pos-right)))
  74                                      (if p
  75                                          (progn (draw-bloc p) (draw-bloc pos))
  76                                          (draw-bloc pos *query-parent-error-color*))))))))
  77
  78
  79 (defun clear-query-history ()
  80   "Clear the query-string history"
  81   (setf *query-history* (list "")))
  82
  83
  84
  85 (defun leave-query-mode (&optional (return :Escape))
  86   "Leave the query mode"
  87   (setf *query-return* return)
  88   (throw 'exit-query-loop nil))
  89
  90
  91 (defun leave-query-mode-valid ()
  92   (leave-query-mode :Return))
  93
  94 (add-hook *binding-hook* 'init-*query-keys*)
  95
  96
  97
  98 (defun query-find-complet-list ()
  99   (let* ((pos (1+ (or (position-if-not #'extented-alphanumericp *query-string*
 100                                        :end *query-pos* :from-end t)
 101                       -1)))
 102          (str (subseq *query-string* pos *query-pos*)))
 103     (when (or (> (length str) (1- *query-min-complet-char*))
 104               (< (length *query-complet-list*) *query-max-complet-length*))
 105       (values (string-match str *query-complet-list*) pos))))
 106
 107
 108 (defun query-print-string ()
 109   (let ((dec (min 0 (- (- (x-drawable-width *query-window*) 10)
 110                        (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))))))
 111         (complet (query-find-complet-list)))
 112     (clear-pixmap-buffer *query-window* *query-gc*)
 113     (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*))
 114     (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5)
 115                       (format nil "~A ~{~A~^, ~}" *query-message*
 116                               (if (< (length complet) *query-max-complet-length*)
 117                                   complet nil)))
 118     (when (< *query-pos* 0)
 119       (setf *query-pos* 0))
 120     (when (> *query-pos* (length *query-string*))
 121       (setf *query-pos* (length *query-string*)))
 122     (query-show-paren *query-string* *query-pos* dec)
 123     (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*))
 124     (xlib:draw-glyphs *pixmap-buffer* *query-gc*
 125                       (+ 10 dec)
 126                       (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 5)
 127                       *query-string*)
 128     (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-cursor-color*))
 129     (xlib:draw-line *pixmap-buffer* *query-gc*
 130                     (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)) dec)
 131                     (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 6)
 132                     (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)) dec)
 133                     (+ (* 1 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 7))
 134     (copy-pixmap-buffer *query-window* *query-gc*)))
 135
 136
 137
 138 (defun query-enter-function ()
 139   (setf *query-font* (xlib:open-font *display* *query-font-string*))
 140   (let ((width (- (xlib:screen-width *screen*) 2))
 141         (height (* 3 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*)))))
 142     (with-placement (*query-mode-placement* x y width height)
 143       (setf *query-window* (xlib:create-window :parent *root*
 144                                                :x x :y y
 145                                                :width width
 146                                                :height height
 147                                                :background (get-color *query-background*)
 148                                                :border-width *border-size*
 149                                                :border (get-color *query-border*)
 150                                                :colormap (xlib:screen-default-colormap *screen*)
 151                                                :event-mask '(:exposure :key-press))
 152             *query-gc* (xlib:create-gcontext :drawable *query-window*
 153                                              :foreground (get-color *query-foreground*)
 154                                              :background (get-color *query-background*)
 155                                              :font *query-font*
 156                                              :line-style :solid))
 157       (setf (window-transparency *query-window*) *query-transparency*)
 158       (map-window *query-window*)
 159       (query-print-string)
 160       (wait-no-key-or-button-press))))
 161
 162
 163
 164 (defun query-leave-function ()
 165   (xlib:destroy-window *query-window*)
 166   (xlib:close-font *query-font*)
 167   (wait-no-key-or-button-press))
 168
 169 (defun query-loop-function ()
 170   (raise-window *query-window*))
 171
 172
 173
 174 (labels ((generic-backspace (del-pos)
 175            (when (>= del-pos 0)
 176              (setf *query-string* (concatenate 'string
 177                                                (subseq *query-string* 0 del-pos)
 178                                                (subseq *query-string* *query-pos*))
 179                    *query-pos* del-pos))))
 180   (defun query-backspace ()
 181     "Delete a character backward"
 182     (generic-backspace (1- *query-pos*)))
 183
 184   (defun query-backspace-word ()
 185     "Delete a word backward"
 186     (generic-backspace (or (position #\Space *query-string* :from-end t :end *query-pos*) 0))))
 187
 188
 189 (labels ((generic-delete (del-pos)
 190            (when (<= del-pos (length *query-string*))
 191              (setf *query-string* (concatenate 'string
 192                                               (subseq *query-string* 0 *query-pos*)
 193                                               (subseq *query-string* del-pos))))))
 194   (defun query-delete ()
 195     "Delete a character forward"
 196     (generic-delete (1+ *query-pos*)))
 197
 198   (defun query-delete-word ()
 199     "Delete a word forward"
 200     (generic-delete (1+ (or (position #\Space *query-string* :start *query-pos*)
 201                             (1- (length *query-string*)))))))
 202
 203
 204
 205 (defun query-home ()
 206   "Move cursor to line begining"
 207   (setf *query-pos* 0))
 208
 209 (defun query-end ()
 210   "Move cursor to line end"
 211   (setf *query-pos* (length *query-string*)))
 212
 213
 214 (defun query-left ()
 215   "Move cursor to left"
 216   (when (> *query-pos* 0)
 217     (setf *query-pos* (1- *query-pos*))))
 218
 219 (defun query-left-word ()
 220   "Move cursor to left word"
 221   (when (> *query-pos* 0)
 222     (setf *query-pos* (let ((p (position #\Space *query-string*
 223                                          :end (min (1- *query-pos*) (length *query-string*))
 224                                          :from-end t)))
 225                         (if p p 0)))))
 226
 227 (defun query-right ()
 228   "Move cursor to right"
 229   (when (< *query-pos* (length *query-string*))
 230     (setf *query-pos* (1+ *query-pos*))))
 231
 232 (defun query-right-word ()
 233   "Move cursor to right word"
 234   (when (< *query-pos* (length *query-string*))
 235     (setf *query-pos* (let ((p (position #\Space *query-string*
 236                                          :start (min (1+ *query-pos*) (length *query-string*)))))
 237                         (if p p (length *query-string*))))))
 238
 239 (defun query-previous-history ()
 240   "Circulate backward in history"
 241   (setf *query-string* (first *query-history*)
 242         *query-pos* (length *query-string*)
 243         *query-history* (rotate-list *query-history*)))
 244
 245
 246 (defun query-next-history ()
 247   "Circulate forward in history"
 248   (setf *query-string* (first *query-history*)
 249         *query-pos* (length *query-string*)
 250         *query-history* (anti-rotate-list *query-history*)))
 251
 252
 253
 254 (defun query-delete-eof ()
 255   "Delete the end of the line"
 256   (setf *query-string* (subseq *query-string* 0 *query-pos*)))
 257
 258
 259 (defun query-mode-complet ()
 260   (multiple-value-bind (complet pos)
 261       (query-find-complet-list)
 262     (when complet
 263       (if (= (length complet) 1)
 264           (setf *query-string* (concatenate 'string
 265                                             (subseq *query-string* 0 pos)
 266                                             (first complet) " "
 267                                             (subseq *query-string* *query-pos*))
 268                 *query-pos* (+ pos (length (first complet)) 1))
 269           (let ((common (find-common-string (subseq *query-string* pos *query-pos*) complet)))
 270             (when common
 271               (setf *query-string* (concatenate 'string
 272                                                 (subseq *query-string* 0 pos)
 273                                                 common
 274                                                 (subseq *query-string* *query-pos*))
 275                     *query-pos* (+ pos (length common)))))))))
 276
 277
 278 (add-hook *binding-hook* 'set-default-query-keys)
 279
 280 (defun set-default-query-keys ()
 281   (define-query-key ("Return") 'leave-query-mode-valid)
 282   (define-query-key ("Escape") 'leave-query-mode)
 283   (define-query-key ("g" :control) 'leave-query-mode)
 284   (define-query-key ("Tab") 'query-mode-complet)
 285   (define-query-key ("BackSpace") 'query-backspace)
 286   (define-query-key ("BackSpace" :control) 'query-backspace-word)
 287   (define-query-key ("Delete") 'query-delete)
 288   (define-query-key ("Delete" :control) 'query-delete-word)
 289   (define-query-key ("Home") 'query-home)
 290   (define-query-key ("a" :control) 'query-home)
 291   (define-query-key ("End") 'query-end)
 292   (define-query-key ("e" :control) 'query-end)
 293   (define-query-key ("Left") 'query-left)
 294   (define-query-key ("Left" :control) 'query-left-word)
 295   (define-query-key ("Right") 'query-right)
 296   (define-query-key ("Right" :control) 'query-right-word)
 297   (define-query-key ("Up") 'query-previous-history)
 298   (define-query-key ("Down") 'query-next-history)
 299   (define-query-key ("k" :control) 'query-delete-eof))
 300
 301
 302
 303 (defun add-in-query-string (code state)
 304   (let* ((modifiers (state->modifiers state))
 305          (keysym (keycode->keysym code modifiers))
 306          (char (xlib:keysym->character *display* keysym state)))
 307     (when (and char (characterp char))
 308       (setf *query-string* (concatenate 'string
 309                                         (when (<= *query-pos* (length *query-string*))
 310                                           (subseq *query-string* 0 *query-pos*))
 311                                         (string char)
 312                                         (when (< *query-pos* (length *query-string*))
 313                                           (subseq *query-string* *query-pos*))))
 314       (incf *query-pos*))))
 315
 316
 317
 318 (define-handler query-mode :key-press (code state)
 319   (unless (funcall-key-from-code *query-keys* code state)
 320     (add-in-query-string code state))
 321   (query-print-string))
 322
 323
 324
 325 (defun  query-string (message &optional (default "") complet-list)
 326   "Query a string from the keyboard. Display msg as prompt"
 327   (let ((grab-keyboard-p (xgrab-keyboard-p))
 328         (grab-pointer-p (xgrab-pointer-p)))
 329     (setf *query-message* message
 330           *query-string* default
 331           *query-pos* (length default)
 332           *query-complet-list* complet-list)
 333     (xgrab-pointer *root* 92 93)
 334     (unless grab-keyboard-p
 335       (ungrab-main-keys)
 336       (xgrab-keyboard *root*))
 337     (generic-mode 'query-mode 'exit-query-loop
 338                   :enter-function #'query-enter-function
 339                   :loop-function #'query-loop-function
 340                   :leave-function #'query-leave-function
 341                   :original-mode '(main-mode))
 342     (unless grab-keyboard-p
 343       (xungrab-keyboard)
 344       (grab-main-keys))
 345     (if grab-pointer-p
 346         (xgrab-pointer *root* 66 67)
 347         (xungrab-pointer)))
 348   (when (equal *query-return* :Return)
 349     (pushnew default *query-history* :test #'equal)
 350     (push *query-string* *query-history*))
 351   (values *query-string*
 352           *query-return*))
 353
 354
 355
 356 (defun query-number (msg &optional (default 0))
 357   "Query a number from the query input"
 358   (multiple-value-bind (string return)
 359       (query-string msg (format nil "~A" default))
 360     (if (equal return :Return)
 361         (or (parse-integer (or string "") :junk-allowed t) default)
 362         default)))