src/clfswm-query.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Query utility
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2005-2013 Philippe Brochard <pbrochard@common-lisp.net>
   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 (defparameter *query-completion-state* nil)
  36
  37 (defparameter *query-message* nil)
  38 (defparameter *query-string* nil)
  39 (defparameter *query-pos* nil)
  40 (defparameter *query-return* nil)
  41
  42
  43 (defun add-char-in-query-string (char)
  44   (setf *query-string* (ensure-printable
  45                         (concatenate 'string
  46                                      (when (<= *query-pos* (length *query-string*))
  47                                        (subseq *query-string* 0 *query-pos*))
  48                                      (string char)
  49                                      (when (< *query-pos* (length *query-string*))
  50                                        (subseq *query-string* *query-pos*)))))
  51   (incf *query-pos*))
  52
  53
  54 (defun query-show-paren (orig-string pos dec)
  55   "Replace matching parentheses with brackets"
  56   (let ((string (copy-seq orig-string)))
  57     (labels ((have-to-find-right? ()
  58                (and (< pos (length string)) (char= (aref string pos) #\()))
  59              (have-to-find-left? ()
  60                (and (> (1- pos) 0) (char= (aref string (1- pos)) #\))))
  61              (pos-right ()
  62                (loop :for p :from (1+ pos) :below (length string)
  63                   :with level = 1   :for c = (aref string p)
  64                   :do (when (char= c #\() (incf level))
  65                   (when (char= c #\)) (decf level))
  66                   (when (= level 0) (return p))))
  67              (pos-left ()
  68                (loop :for p :from (- pos 2) :downto 0
  69                   :with level = 1   :for c = (aref string p)
  70                   :do (when (char= c #\() (decf level))
  71                   (when (char= c #\)) (incf level))
  72                   (when (= level 0) (return p))))
  73              (draw-bloc (p &optional (color *query-parent-color*))
  74                (setf (xlib:gcontext-foreground *query-gc*) (get-color color))
  75                (xlib:draw-rectangle *pixmap-buffer* *query-gc*
  76                                     (+ 10 (* p (xlib:max-char-width *query-font*)) dec)
  77                                     (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*) 7)
  78                                     (xlib:max-char-width *query-font*)
  79                                     (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))
  80                                     t)))
  81       (cond ((have-to-find-left?) (let ((p (pos-left)))
  82                                     (if p
  83                                         (progn (draw-bloc p) (draw-bloc (1- pos)))
  84                                         (draw-bloc (1- pos) *query-parent-error-color*))))
  85             ((have-to-find-right?) (let ((p (pos-right)))
  86                                      (if p
  87                                          (progn (draw-bloc p) (draw-bloc pos))
  88                                          (draw-bloc pos *query-parent-error-color*))))))))
  89
  90
  91 (defun clear-query-history ()
  92   "Clear the query-string history"
  93   (setf *query-history* (list "")))
  94
  95
  96
  97 (defun leave-query-mode (&optional (return :Escape))
  98   "Leave the query mode"
  99   (setf *query-return* return)
 100   (throw 'exit-query-loop nil))
 101
 102
 103 (defun leave-query-mode-valid ()
 104   (leave-query-mode :Return))
 105
 106 (add-hook *binding-hook* 'init-*query-keys*)
 107
 108
 109
 110 (defun query-find-complet-list ()
 111   (let* ((pos (1+ (or (position-if-not #'extented-alphanumericp *query-string*
 112                                        :end *query-pos* :from-end t)
 113                       -1)))
 114          (str (subseq *query-string* pos *query-pos*)))
 115     (when (or (> (length str) (1- *query-min-complet-char*))
 116               (< (length *query-complet-list*) *query-max-complet-length*))
 117       (values (string-match str *query-complet-list*) pos))))
 118
 119
 120 (defun query-print-string ()
 121   (let ((dec (min 0 (- (- (x-drawable-width *query-window*) 10)
 122                        (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))))))
 123         (complet (if *query-completion-state*
 124                      (first *query-completion-state*)
 125                      (query-find-complet-list))))
 126     (clear-pixmap-buffer *query-window* *query-gc*)
 127     (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*))
 128     (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5)
 129                       (format nil "~A ~{~A~^, ~}" *query-message*
 130                               (if (< (length complet) *query-max-complet-length*)
 131                                   complet nil)))
 132     (when (< *query-pos* 0)
 133       (setf *query-pos* 0))
 134     (when (> *query-pos* (length *query-string*))
 135       (setf *query-pos* (length *query-string*)))
 136     (query-show-paren *query-string* *query-pos* dec)
 137     (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*))
 138     (xlib:draw-glyphs *pixmap-buffer* *query-gc*
 139                       (+ 10 dec)
 140                       (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 5)
 141                       (ensure-printable *query-string*))
 142     (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-cursor-color*))
 143     (xlib:draw-line *pixmap-buffer* *query-gc*
 144                     (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)) dec)
 145                     (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 6)
 146                     (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)) dec)
 147                     (+ (* 1 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 7))
 148     (copy-pixmap-buffer *query-window* *query-gc*)))
 149
 150
 151
 152 (defun query-enter-function ()
 153   (setf *query-font* (xlib:open-font *display* *query-font-string*))
 154   (let ((width (- (screen-width) 2))
 155         (height (* 3 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*)))))
 156     (with-placement (*query-mode-placement* x y width height)
 157       (setf *query-window* (xlib:create-window :parent *root*
 158                                                :x x :y y
 159                                                :width width
 160                                                :height height
 161                                                :background (get-color *query-background*)
 162                                                :border-width *border-size*
 163                                                :border (get-color *query-border*)
 164                                                :colormap (xlib:screen-default-colormap *screen*)
 165                                                :event-mask '(:exposure :key-press))
 166             *query-gc* (xlib:create-gcontext :drawable *query-window*
 167                                              :foreground (get-color *query-foreground*)
 168                                              :background (get-color *query-background*)
 169                                              :font *query-font*
 170                                              :line-style :solid))
 171       (setf (window-transparency *query-window*) *query-transparency*)
 172       (map-window *query-window*)
 173       (query-print-string)
 174       (wait-no-key-or-button-press))))
 175
 176
 177
 178 (defun query-leave-function ()
 179   (xlib:destroy-window *query-window*)
 180   (xlib:close-font *query-font*)
 181   (wait-no-key-or-button-press))
 182
 183 (defun query-loop-function ()
 184   (raise-window *query-window*))
 185
 186
 187
 188 (labels ((generic-backspace (del-pos)
 189            (when (>= del-pos 0)
 190              (setf *query-string* (concatenate 'string
 191                                                (subseq *query-string* 0 del-pos)
 192                                                (subseq *query-string* *query-pos*))
 193                    *query-pos* del-pos))))
 194   (defun query-backspace ()
 195     "Delete a character backward"
 196     (generic-backspace (1- *query-pos*)))
 197
 198   (defun query-backspace-word ()
 199     "Delete a word backward"
 200     (generic-backspace (or (position #\Space *query-string* :from-end t :end *query-pos*) 0)))
 201
 202   (defun query-backspace-clear ()
 203     "Delete backwards until beginning"
 204     (generic-backspace 0)))
 205
 206 (labels ((generic-delete (del-pos)
 207            (when (<= del-pos (length *query-string*))
 208              (setf *query-string* (concatenate 'string
 209                                               (subseq *query-string* 0 *query-pos*)
 210                                               (subseq *query-string* del-pos))))))
 211   (defun query-delete ()
 212     "Delete a character forward"
 213     (generic-delete (1+ *query-pos*)))
 214
 215   (defun query-delete-word ()
 216     "Delete a word forward"
 217     (generic-delete (1+ (or (position #\Space *query-string* :start *query-pos*)
 218                             (1- (length *query-string*)))))))
 219
 220
 221
 222 (defun query-home ()
 223   "Move cursor to line begining"
 224   (setf *query-pos* 0))
 225
 226 (defun query-end ()
 227   "Move cursor to line end"
 228   (setf *query-pos* (length *query-string*)))
 229
 230
 231 (defun query-left ()
 232   "Move cursor to left"
 233   (when (> *query-pos* 0)
 234     (setf *query-pos* (1- *query-pos*))))
 235
 236 (defun query-left-word ()
 237   "Move cursor to left word"
 238   (when (> *query-pos* 0)
 239     (setf *query-pos* (let ((p (position #\Space *query-string*
 240                                          :end (min (1- *query-pos*) (length *query-string*))
 241                                          :from-end t)))
 242                         (if p p 0)))))
 243
 244 (defun query-right ()
 245   "Move cursor to right"
 246   (when (< *query-pos* (length *query-string*))
 247     (setf *query-pos* (1+ *query-pos*))))
 248
 249 (defun query-right-word ()
 250   "Move cursor to right word"
 251   (when (< *query-pos* (length *query-string*))
 252     (setf *query-pos* (let ((p (position #\Space *query-string*
 253                                          :start (min (1+ *query-pos*) (length *query-string*)))))
 254                         (if p p (length *query-string*))))))
 255
 256 (defun query-previous-history ()
 257   "Circulate backward in history"
 258   (setf *query-string* (first *query-history*)
 259         *query-pos* (length *query-string*)
 260         *query-history* (rotate-list *query-history*)))
 261
 262
 263 (defun query-next-history ()
 264   "Circulate forward in history"
 265   (setf *query-string* (first *query-history*)
 266         *query-pos* (length *query-string*)
 267         *query-history* (anti-rotate-list *query-history*)))
 268
 269
 270
 271 (defun query-delete-eof ()
 272   "Delete the end of the line"
 273   (setf *query-string* (subseq *query-string* 0 *query-pos*)))
 274
 275
 276 (defun query-mode-complet ()
 277   (multiple-value-bind (complet pos)
 278       (query-find-complet-list)
 279     (when complet
 280       (if (= (length complet) 1)
 281           (setf *query-string* (concatenate 'string
 282                                             (subseq *query-string* 0 pos)
 283                                             (first complet) " "
 284                                             (subseq *query-string* *query-pos*))
 285                 *query-pos* (+ pos (length (first complet)) 1))
 286           (let ((common (find-common-string (subseq *query-string* pos *query-pos*) complet)))
 287             (when common
 288               (setf *query-string* (concatenate 'string
 289                                                 (subseq *query-string* 0 pos)
 290                                                 common
 291                                                 (subseq *query-string* *query-pos*))
 292                     *query-pos* (+ pos (length common)))))))))
 293
 294 (defun query-mode-complete-suggest ()
 295   (flet ((complete (completions completion-pos pos initial-pos)
 296            (when completions
 297              (let ((completion (if (equal completion-pos (list-length completions))
 298                                    (subseq *query-string* pos initial-pos)
 299                                    (nth completion-pos completions))))
 300                (setf *query-string* (concatenate 'string
 301                                                  (subseq *query-string* 0 pos)
 302                                                  completion
 303                                                  (subseq *query-string* *query-pos*))
 304                      *query-pos* (+ pos (length completion))))
 305              (setf *query-completion-state*
 306                    (list completions completion-pos pos initial-pos)))))
 307     (if *query-completion-state*
 308         (complete (first *query-completion-state*)
 309                   (mod (1+ (second *query-completion-state*))
 310                        (1+ (list-length (first *query-completion-state*))))
 311                   (third *query-completion-state*)
 312                   (fourth *query-completion-state*))
 313         (multiple-value-bind (comps pos) (query-find-complet-list)
 314           (complete comps 0 pos *query-pos*)))))
 315
 316 (add-hook *query-key-press-hook* 'query-mode-complete-suggest-reset)
 317
 318 (defun query-mode-complete-suggest-reset (code state)
 319   "Reset the query-completion-state if another key was pressed than a key
 320 that calls query-mode-complete-suggest."
 321   (unless (equal 'query-mode-complete-suggest
 322                  (first (find-key-from-code *query-keys* code state)))
 323     (setf *query-completion-state* nil)
 324     (query-print-string)))
 325
 326 (add-hook *binding-hook* 'set-default-query-keys)
 327
 328 (defun set-default-query-keys ()
 329   (define-query-key ("Return") 'leave-query-mode-valid)
 330   (define-query-key ("Escape") 'leave-query-mode)
 331   (define-query-key ("g" :control) 'leave-query-mode)
 332   (define-query-key ("Tab") 'query-mode-complet)
 333   (define-query-key ("BackSpace") 'query-backspace)
 334   (define-query-key ("BackSpace" :control) 'query-backspace-word)
 335   (define-query-key ("BackSpace" :control :shift) 'query-backspace-clear)
 336   (define-query-key ("u" :control) 'query-backspace-clear)
 337   (define-query-key ("Delete") 'query-delete)
 338   (define-query-key ("Delete" :control) 'query-delete-word)
 339   (define-query-key ("Home") 'query-home)
 340   (define-query-key ("a" :control) 'query-home)
 341   (define-query-key ("End") 'query-end)
 342   (define-query-key ("e" :control) 'query-end)
 343   (define-query-key ("Left") 'query-left)
 344   (define-query-key ("Left" :control) 'query-left-word)
 345   (define-query-key ("Right") 'query-right)
 346   (define-query-key ("Right" :control) 'query-right-word)
 347   (define-query-key ("Up") 'query-previous-history)
 348   (define-query-key ("Down") 'query-next-history)
 349   (define-query-key ("k" :control) 'query-delete-eof)
 350   (define-query-key ("KP_Insert" :mod-2) 'add-char-in-query-string "0")
 351   (define-query-key ("KP_End" :mod-2) 'add-char-in-query-string "1")
 352   (define-query-key ("KP_Down" :mod-2) 'add-char-in-query-string "2")
 353   (define-query-key ("KP_Page_Down" :mod-2) 'add-char-in-query-string "3")
 354   (define-query-key ("KP_Left" :mod-2) 'add-char-in-query-string "4")
 355   (define-query-key ("KP_Begin" :mod-2) 'add-char-in-query-string "5")
 356   (define-query-key ("KP_Right" :mod-2) 'add-char-in-query-string "6")
 357   (define-query-key ("KP_Home" :mod-2) 'add-char-in-query-string "7")
 358   (define-query-key ("KP_Up" :mod-2) 'add-char-in-query-string "8")
 359   (define-query-key ("KP_Page_Up" :mod-2) 'add-char-in-query-string "9")
 360   (define-query-key ("KP_Delete" :mod-2) 'add-char-in-query-string ".")
 361   (define-query-key ("KP_Add" :mod-2) 'add-char-in-query-string "+")
 362   (define-query-key ("KP_Subtract" :mod-2) 'add-char-in-query-string "-")
 363   (define-query-key ("KP_Multiply" :mod-2) 'add-char-in-query-string "*")
 364   (define-query-key ("KP_Divide" :mod-2) 'add-char-in-query-string "/")
 365   (define-query-key ("KP_Enter" :mod-2) 'leave-query-mode-valid))
 366
 367
 368
 369 (defun add-in-query-string (code state)
 370   (let* ((modifiers (state->modifiers state))
 371          (keysym (keycode->keysym code modifiers))
 372          (char (xlib:keysym->character *display* keysym state)))
 373     (when (and char (characterp char))
 374       (add-char-in-query-string char))))
 375
 376
 377
 378 (define-handler query-mode :key-press (code state)
 379   (unless (funcall-key-from-code *query-keys* code state)
 380     (add-in-query-string code state))
 381   (query-print-string)
 382   (call-hook *query-key-press-hook* code state))
 383
 384 (define-handler query-mode :button-press (code state x y)
 385   (call-hook *query-button-press-hook* code state x y))
 386
 387
 388
 389 (defun  query-string (message &optional (default "") complet-list)
 390   "Query a string from the keyboard. Display msg as prompt"
 391   (setf *query-message* message
 392         *query-string* default
 393         *query-pos* (length default)
 394         *query-complet-list* complet-list
 395         *query-completion-state* nil)
 396   (with-grab-keyboard-and-pointer (92 93 66 67 t)
 397     (generic-mode 'query-mode 'exit-query-loop
 398                   :enter-function #'query-enter-function
 399                   :loop-function #'query-loop-function
 400                   :leave-function #'query-leave-function
 401                   :original-mode '(main-mode)))
 402   (when (equal *query-return* :Return)
 403     (pushnew default *query-history* :test #'equal)
 404     (push *query-string* *query-history*))
 405   (values *query-string*
 406           *query-return*))
 407
 408
 409
 410 (defun query-number (msg &optional (default 0))
 411   "Query a number from the query input"
 412   (multiple-value-bind (string return)
 413       (query-string msg (format nil "~A" default))
 414     (values (if (equal return :Return)
 415                 (or (parse-integer (or string "") :junk-allowed t) default)
 416                 default)
 417             return)))