tinmop/src/keybindings.lisp

;; tinmop: a multiprotocol client
;; Copyright © cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].

(in-package :keybindings)

(define-constant +control-prefix+             "^"                            :test #'string=)

(define-constant +meta-prefix+                "ALT-"                         :test #'string=)

(define-constant +function-placeholder-re+    "function-placeholder"         :test #'string=)

(define-constant +function-placeholder-value+ :fn                            :test #'string=)

(defparameter   *default-prefix*              nil)

;; KEYPATH              := KEY KEYPATH
;;                         | epsilon
;; KEY                  := COMMAND-KEY
;;                         | META-KEY
;;                         | KEYCODE
;;                         | FUNCTION-PLACEHOLDER
;; COMMAND-KEY          := ( (COMMAND-MOD-1 DASH) | COMMAND-MOD-2 ) KEYCODE
;; META-KEY             := META-MOD DASH AFTER-META-KEYCODE
;; KEYCODE              := NON-PRINTABLE-KEY | SIMPLE-KEY
;; AFTER-META-KEYCODE   := AFTER-META-KEY | SIMPLE-KEY
;; AFTER-META-KEY       := 'right'
;;                         |'left'
;;                         |'up'
;;                         |'down'
;; SIMPLE-KEY           := CHAR
;; NON-PRINTABLE-KEY    := 'f1'
;;                         |'f2'
;;                         |'f3'
;;                         |'f4'
;;                         |'f5'
;;                         |'f6'
;;                         |'f7'
;;                         |'f8'
;;                         |'f9'
;;                         |'f10
;;                         | 'key-arrow-right'
;;                         | 'key-arrow-left'
;;                         | 'key-arrow-up'
;;                         | 'key-arrow-down'
;;                         | 'key-home'
;;                         | 'key-end'
;;                         | 'key-next-page'
;;                         | 'key-previous-page'
;;                         | 'key-delete-char'
;;                         | ARROW-RIGHT
;;                         | ARROW-LEFT
;;                         | ARROW-UP
;;                         | ARROW-DOWN
;;                         | KEY-HOME
;;                         | KEY-END
;;                         | KEY-NEXT-PAGE
;;                         | KEY-PREVIOUS-PAGE
;;                         | KEY-DELETE-NEXT-CHAR
;; ARROW-RIGHT          := 'right'
;; ARROW-LEFT           := 'left'
;; ARROW-UP             := 'up'
;; ARROW-DOWN           := 'down'
;; KEY-HOME             := 'home'
;; KEY-END              := 'end'
;; KEY-NEXT-PAGE        := 'npage'
;; KEY-PREVIOUS-PAGE    := 'ppage'
;; KEY-DELETE-NEXT-CHAR := 'dc'
;; COMMAND-MOD-1        := 'C'
;; COMMAND-MOD-2        := '^'
;; META-MOD             := 'M'
;; DASH                 := '-'
;; CHAR                 := ESCAPED-CHAR | (not ( DASH | BLANK))
;; BLANKS               := BLANK*
;; BLANK                := #\space | #\Newline | #\Tab
;; FUNCTION-PLACEHOLDER := 'function-placeholder'


(defrule function-placeholder "function-placeholder"
  (:constant +function-placeholder-value+))

(defrule blank (or #\space #\Newline #\Tab)
  (:constant nil))

(defrule blanks (* blank)
  (:constant nil))

(defrule escaped-character (and #\\ character)
  (:function (lambda (a) (list (second a)))))

(defrule dash #\-
  (:text t))

(defrule arrow-right "right"
  (:constant "key-arrow-right"))

(defrule arrow-left "left"
  (:constant "key-arrow-left"))

(defrule arrow-up "up"
  (:constant "key-arrow-up"))

(defrule arrow-down "down"
  (:constant "key-arrow-down"))

(defrule key-home "home"
  (:constant "key-home"))

(defrule key-end "end"
  (:constant "key-end"))

(defrule key-next-page "npage"
  (:constant "key-next-page"))

(defrule key-previous-page "ppage"
  (:constant "key-previous-page"))

(defrule key-delete-next-char "dc"
  (:constant "key-delete-char"))

(defrule non-printable-key
    (or "f10"
        "f1"
        "f2"
        "f3"
        "f4"
        "f5"
        "f6"
        "f7"
        "f8"
        "f9"
        "key-arrow-right"
        "key-arrow-left"
        "key-arrow-up"
        "key-arrow-down"
        "key-home"
        "key-end"
        "key-next-page"
        "key-previous-page"
        "key-delete-char"
        arrow-right
        arrow-left
        arrow-up
        arrow-down
        key-home
        key-end
        key-next-page
        key-previous-page
        key-delete-next-char)
  (:text t)
  (:function string-upcase))

(defrule after-meta-key
    (or "right"
        "left"
        "up"
        "down")
  (:text t)
  (:function string-upcase))

(defrule char
    (or escaped-character
        (not (or dash blank)))
  (:text t))

(defrule meta-mod #\M
  (:text t))

(defrule command-mod-1 #\C)

(defrule command-mod-2 #\^)

(defrule simple-key char)

(defrule keycode (or non-printable-key simple-key)) ; keep the order

(defrule after-meta-keycode (or after-meta-key simple-key)) ; keep the order

(defun to-meta-code-string (command)
  (strcat +meta-prefix+ (string-upcase (third command))))

(defrule meta-key
    (and meta-mod dash after-meta-keycode)
  (:function to-meta-code-string)
  (:text t))

(defun to-control-code-string (command)
  (strcat +control-prefix+ (string-upcase (third command))))

;; not part of the actual grammar, just syntactic sugar

(defrule command-key-1
    (and command-mod-1 dash keycode)
  (:function to-control-code-string))

(defrule command-key-2
    (and command-mod-2 keycode)
  (:text t))

(defrule command-key
    (or command-key-1
        command-key-2))

(defrule key
    (and (or function-placeholder ; keep the order
             command-key
             meta-key
             keycode)
         (? blanks))
  (:function first))

(defrule keypath
    (and key (? keypath))
  (:function (lambda (a) (remove-if-null (flatten a)))))

(defun make-starting-comand-tree ()
  (make-command-tree *default-prefix*))

(defun make-command-tree (data)
  (make-instance 'sorted-m-tree
                 :data       data
                 :compare-fn #'string<))

(defun parse-keypath (keypath &key (existing-tree (make-starting-comand-tree)))
  "Parse a string representing a list of keys (see `*global-keymap*'),
produces a tree and graft the latter on `existing-tree'"
  (labels ((placeholderp (child)
             (eq +function-placeholder-value+
                 (data child)))
           (remove-function-siblings (node)
             (top-down-visit node
                             (lambda (a)
                               (if (find-if #'placeholderp (children a))
                                   (setf (children a)
                                         (remove-if-not #'placeholderp (children a)))))))
           (remove-function-children (node)
             (top-down-visit node
                             (lambda (a)
                               (when (placeholderp a)
                                 (remove-all-children a)))))
           (add (tree commands)
             (if commands
                 (let ((new-node (make-command-tree (first commands))))
                   (add-child tree new-node)
                   (add new-node (rest commands)))
                 nil)))
    (let ((raw      (parse 'keypath (strcat keypath " " +function-placeholder-re+)))
          (new-tree (make-starting-comand-tree)))
      (add  new-tree raw)
      (graft-branch existing-tree
                    new-tree
                    :test (lambda (a b)
                            (cond
                              ((functionp a)
                               t)
                              ((eq b +function-placeholder-value+)
                               t)
                              (t
                               (string= a b)))))
      (remove-function-siblings existing-tree)
      (remove-function-children existing-tree)
      existing-tree)))

(defparameter *global-keymap* (make-starting-comand-tree)
  "The global keymap.

   A keymap looks like a tree with function as leaf nodes like:

       a
      / \
     b   c
    /   / \
   #'+ b   d
      /     \
      #'*    #'-

  So, pressing a sequence of 'a -> c -> d' will trigger the function #'-

")

(defparameter *thread-keymap* (make-starting-comand-tree)
  "The keymap for thread window.")

(defparameter *message-keymap* (make-starting-comand-tree)
  "The keymap for message window.")

(defparameter *gemini-message-keymap* (make-starting-comand-tree)
  "The keymap for message-window when displaing gemini text.")

(defparameter *tags-keymap* (make-starting-comand-tree)
  "The keymap for tags window.")

(defparameter *conversations-keymap* (make-starting-comand-tree)
  "The keymap for conversations windows.")

(defparameter *send-message-keymap* (make-starting-comand-tree)
  "The keymap for window to confirm sending a message.")

(defparameter *follow-requests-keymap* (make-starting-comand-tree)
  "The keymap for window to accept follow requests.")

(defparameter *open-attach-keymap* (make-starting-comand-tree)
  "The keymap for window to open message's attachments.")

(defparameter *open-message-link-keymap* (make-starting-comand-tree)
  "The keymap for window to open message's links.")

(defparameter *open-gemini-link-keymap* (make-starting-comand-tree)
  "The keymap for window to open gemini's links.")

(defparameter *gemini-downloads-keymap* (make-starting-comand-tree)
  "The keymap for window that shows all gemini streams.")

(defparameter *gemini-certificates-keymap* (make-starting-comand-tree)
  "The keymap for window that shows all gemini certificates.")

(defparameter *chats-list-keymap* (make-starting-comand-tree)
  "The keymap for window that shows all the chats.")

(defparameter *chat-message-keymap* (make-starting-comand-tree)
  "The keymap for message-window when shows chat.")

(defparameter *gemlog-subscription-keymap*  (make-starting-comand-tree)
  "The keymap for gemlog subscriptions window.")

(defparameter *gemini-toc-keymap*  (make-starting-comand-tree)
  "The keymap for gemini table of contents window.")

(defparameter *gempub-library-keymap* (make-starting-comand-tree)
  "The keymap for gempub library of publication.")

(defparameter *filesystem-explorer-keymap* (make-starting-comand-tree)
  "The keymap for gempub library of publication.")

(defparameter *gopher-keymap* (make-starting-comand-tree)
  "The keymap for gempub library of publication.")

(defparameter *all-keymaps* '(*global-keymap*
                              *thread-keymap*
                              *message-keymap*
                              *gemini-message-keymap*
                              *tags-keymap*
                              *conversations-keymap*
                              *send-message-keymap*
                              *follow-requests-keymap*
                              *open-attach-keymap*
                              *open-message-link-keymap*
                              *open-gemini-link-keymap*
                              *gemini-downloads-keymap*
                              *gemini-certificates-keymap*
                              *chats-list-keymap*
                              *chat-message-keymap*
                              *gemlog-subscription-keymap*
                              *gemini-toc-keymap*
                              *gempub-library-keymap*
                              *filesystem-explorer-keymap*
                              *gopher-keymap*))

(defun define-key (key-sequence function &optional (existing-keymap *global-keymap*))
  "Define a key sequence that trigger a function:

   The syntax is a simple list of keys or a single key:

   - key [key ...]

   where   key    can   be    either   a   printable    character,   a
   <control>-character code or ALT-character.  A character code can be
   defined using  caret notation:  '^character' (e.g.  '^A')  or using
   'C-' as placeholder for <control> (e.g. 'C-A').

   The allowed character in alt-character code are downcase only.

   Please note that this function will modify existing keymap.
"
  (let* ((tree        (parse-keypath key-sequence :existing-tree existing-keymap))
         (placeholder (find-child tree +function-placeholder-value+ :compare #'eq)))
    (assert placeholder)
    (assert (functionp function))
    (setf (data placeholder) function)
    tree))

(define-constant +croatoan-last-standard-key+ 511 :test #'=)

(defclass encoded-map-entry ()
  ((terminal-code
    :initform nil
    :initarg  :terminal-code
    :accessor terminal-code)
   (croatoan-code
    :initform nil
    :initarg  :croatoan-code
    :accessor croatoan-code)
   (curses-code
    :initform nil
    :initarg  :curses-code
    :accessor curses-code))
  (:documentation "terminal-code:  the raw string that the terminal provide to encode a key
   croatoan-code:  ther symbol croatoan use and returns to  usercode
   curses-keycode: integer that map terminal-code
   (used internally by croatoan to match croatoan-code
   Example: \"^[1\" :alt-1 512.
   Note that \"^]\" is the character #\Esc"))

(defmethod print-object ((object encoded-map-entry) stream)
  (print-unreadable-object (object stream :type t :identity nil)
    (with-accessors ((terminal-code terminal-code)
                     (croatoan-code croatoan-code)
                     (curses-code   curses-code)) object
      (format stream "~s ~s ~s" terminal-code croatoan-code curses-code))))

(defun make-encoded-map-entry (terminal-code croatoan-code curses-code)
  (make-instance 'encoded-map-entry
                 :terminal-code terminal-code
                 :croatoan-code croatoan-code
                 :curses-code   curses-code))

(defun term-escaped-sequence (&rest chars)
  (append (list #\Esc)
          chars))

(defun other-codes ()
    "Others keycode (the terminal encoding is non standard and will requires tweak).
Values a list of `encoded-map-entry'"
    (flet ((collect-codes (from-ascii-code below-ascii-code from-curses-code)
             (loop
                for character-code from from-ascii-code  below below-ascii-code by 1
                for curses-code    from from-curses-code                        by 1 collect
                  (let ((char (code-char character-code)))
                    (make-encoded-map-entry (format nil "~a~a" #\Esc char)              ; terminal
                                            (format-keyword (format nil "alt-~a" char)) ; croatoan
                                            curses-code)))))                            ; curses
      (let* ((number-and-symbols (collect-codes 33 65 (1+ +croatoan-last-standard-key+)))
             (last-curses-code   (curses-code         (last-elt number-and-symbols)))
             (characters         (collect-codes 97
                                                127
                                                (1+ last-curses-code))))
        (setf last-curses-code (curses-code (last-elt characters)))
        (let ((misc (list (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\3 #\D)
                                                  :alt-left
                                                  (+ 1 last-curses-code))
                          (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\3 #\A)
                                                  :alt-up
                                                  (+ 2 last-curses-code))
                          (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\3 #\C)
                                                  :alt-right
                                                  (+ 3 last-curses-code))
                          (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\3 #\B)
                                                  :alt-down
                                                  (+ 4 last-curses-code))
                          (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\5 #\D)
                                                  :control-left
                                                  (+ 5 last-curses-code))
                          (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\5 #\A)
                                                  :control-up
                                                  (+ 6 last-curses-code))
                          (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\5 #\C)
                                                  :control-right
                                                  (+ 7 last-curses-code))
                          (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\5 #\B)
                                                  :control-down
                                                  (+ 8 last-curses-code)))))
        (append number-and-symbols characters misc)))))

(defparameter *local-key-alist* (other-codes))

(defun add-keymap-to-curses-db ()
  "Remove  nonstandard key  form 'croatoan:*key-alist*'  and add  ours
instead"
  (loop for keymapping in *local-key-alist* do
       (croatoan:define-function-key (croatoan-code keymapping) (terminal-code keymapping)
         :key-code (curses-code keymapping))))

(defun init-keyboard-mapping ()
  (add-keymap-to-curses-db))

(defun find-keymap-node (key tree)
  "Find `key' in keymap `tree'.
   Returns the node  of the tree or a function if the node found node
   has a single children (the function to call).
   If `key' can not be found returns nil.
"
  (when-let* ((node-pos (num:binary-search (children tree)
                                           (make-node key)
                                           :compare-fn (lambda (a b)
                                                         (string< (data a) (data b)))
                                           :equal-fn   (lambda (a b)
                                                         (string= (data a) (data b)))))
              (node     (interfaces:clone (elt (children tree) node-pos))))
    (assert (or (null node)
                (not  (leafp node))))
    (setf (parent node) nil)
    (let* ((child-with-function-to-call (find-if (lambda (child) (functionp (data child)))
                                                 (children node)))
           (function-to-call            (and child-with-function-to-call
                                             (data child-with-function-to-call))))
      (or function-to-call
          node))))

(defun humanize-key (key)
  "Transform a node  of the keymap in something that  humans can easly
understand"
  (cond
    ((functionp key)
     (if (documentation key t)
         (with-input-from-string (stream (documentation key t))
           (regex-replace-all "  +" (read-line stream) " "))
         (function-name key)))
    ((string= key "^J")
     (_ "Enter"))
    ((or (string= key "KEY-DELETE-CHAR")
         (string= key "DC"))
     (_ "Delete"))
    ((or (string= key "KEY-NEXT-PAGE")
         (string= key "NPAGE"))
     (_ "Page-up"))
    ((or (string= key "KEY-PREVIOUS-PAGE")
         (string= key "PPAGE"))
     (_ "Page-down"))
    ((or (string= key "KEY-ARROW-DOWN")
         (string= key "UP"))
     (_ "Arrow up"))
    ((or (string= key "KEY-ARROW-UP")
         (string= key "DOWN"))
     (_ "Arrow down"))
    (t
     (to-s key))))

(defun key-paths (keymapping-tree)
  "Transform a keymap tree in a list  of path from root of the tree to
each leaf (as strings)"
  (let ((all-texts     ())
        (all-functions ()))
    (labels ((collect-fn (&optional (starting-path ()))
               (let ((path (copy-list starting-path)))
                 (lambda (node)
                   (let ((data (data node)))
                     (push data path)
                     (if (functionp data)
                         (progn
                           (push (reverse path) all-texts)
                           (push data all-functions))
                         path)))))
             (collect (node &optional (collector (collect-fn)))
               (let* ((path-so-far   (funcall collector node)))
                 (do-children (child node)
                   (let ((new-collector (collect-fn path-so-far)))
                     (collect child new-collector)))))
             (humanize-paths (paths)
               (loop for path in paths collect
                    (mapcar #'humanize-key (rest path))))
             (build-string (paths)
               (mapcar (lambda (a) (format nil
                                           "~a: ~a"
                                           (first a)
                                           (join-with-strings (rest a) " ")))
                       paths)))
      (collect keymapping-tree)
      (mapcar #'make-help-fields
              (build-string (humanize-paths all-texts))
              all-functions))))

(defun help-fields-get-function (fields)
  (getf fields :function))

(defun help-fields-get-text (fields)
  (getf fields :text))

(defun make-help-fields (text function)
  (list :text text :function function))

(defun help-expand (x fields)
  "Expands an entry in quick help window (see function `print-help'
and `make-blocking-list-dialog-window') showing the full docstring for a command"
  (declare (ignore x))
  (when-let* ((function (help-fields-get-function fields))
              (bg       (swconf:win-bg swconf:+key-help-dialog+))
              (fg       (swconf:win-fg swconf:+key-help-dialog+)))
    (windows:make-blocking-message-dialog specials:*main-window*
                                          nil
                                          (function-name function)
                                          (if (string-not-empty-p (documentation function t))
                                              (split-lines (documentation function t))
                                              (list (_ "No documentation available, you can help! :-)")))
                                          bg
                                          fg)))

(defmacro gen-humanize-keymap-name (translations)
  `(defun humanize-keymap-name (keymap-name)
     (cond
       ,@(loop for (name . translation) in translations collect
               `((string-equal keymap-name ',name)
                 ,translation))
       (t keymap-name))))

(gen-humanize-keymap-name ((*global-keymap*              . (_ "Global keymap"))
                           (*thread-keymap*              . (_ "Thread window keymap"))
                           (*message-keymap*             . (_ "Message window keymap"))
                           (*gemini-message-keymap*      . (_ "Gemini page keymap"))
                           (*gopher-keymap*              . (_ "Gopher window keymap"))
                           (*tags-keymap*                . (_ "Subscribed tags keymap"))
                           (*conversations-keymap*       . (_ "Conversation keymap"))
                           (*send-message-keymap*        . (_ "Post pleroma message keymap"))
                           (*follow-requests-keymap*     . (_ "Follow request keymap"))
                           (*open-attach-keymap*         . (_ "Open attachment keymap"))
                           (*open-message-link-keymap*   . (_ "Open link window keymap"))
                           (*open-gemini-link-keymap*    . (_ "Open gemini page's link keymap"))
                           (*gemini-downloads-keymap*    . (_ "Gemini download window keymap"))
                           (*gemini-certificates-keymap* . (_ "Gemini certificate window keymap"))
                           (*chats-list-keymap*          . (_ "Chat list window keymap"))
                           (*chat-message-keymap*        . (_ "Chat window keymap"))
                           (*gemlog-subscription-keymap* . (_ "Gemlog subscription window keymap"))
                           (*gemini-toc-keymap*          . (_ "Gemini page TOC keymap"))
                           (*gempub-library-keymap*      . (_ "Gempub library window keymap"))
                           (*filesystem-explorer-keymap* . (_ "Filesystem explorer"))))


(defun print-help (main-window &key (regex ".*") (global-search nil))
  "Generate an help text for the focused window and main window"
  (multiple-value-bind (header-bg header-fg attribute-header)
      (swconf:quick-help-header-colors)
    (labels ((colorize-header (a)
               (tui-utils:make-tui-string a
                                          :fgcolor    header-fg
                                          :bgcolor    header-bg
                                          :attributes attribute-header))
             (sort-help (help-values)
               (sort help-values
                     (lambda (a b)
                       (let* ((text-a    (help-fields-get-text a))
                              (text-b    (help-fields-get-text b))
                              (alpha-a-p (scan "(?i)^[a-z]" text-a))
                              (alpha-b-p (scan "(?i)^[a-z]" text-b)))
                         (cond
                           ((and alpha-a-p
                                 alpha-b-p)
                            (string< text-a text-b))
                           (alpha-a-p
                            t)
                           (alpha-b-p
                            nil)
                           (t
                            (string< text-a text-b)))))))
             (make-filter-help-text (scanner)
               (lambda (a)
                 (let ((text (help-fields-get-text a))
                       (fn   (help-fields-get-function a)))
                   (or (null fn)
                       (scan scanner
                             (if (stringp text)
                                 text
                                 (tui:tui-string->chars-string text)))))))
             (valid-results-p (fields)
               fields)
             (humanize-keymap-names (keymaps)
               (mapcar (lambda (a) (colorize-header (humanize-keymap-name a)))
                         keymaps)))
      (when-let* ((focused-keybindings   (main-window:focused-keybindings main-window))
                  (all-help              (if global-search
                                             (loop for i in *all-keymaps* collect
                                                (sort-help (key-paths (symbol-value i))))
                                             (list (sort-help (key-paths *global-keymap*))
                                                   (sort-help (key-paths focused-keybindings)))))
                  (headers               (if global-search
                                             (humanize-keymap-names *all-keymaps*)
                                             (humanize-keymap-names (list '*global-keymap*
                                                                          (_ "Focused window keymap")))))
                  (global-header-fields  (mapcar (lambda (a) (make-help-fields a nil))
                                                 headers))
                  (fields                (loop for header in global-header-fields
                                               for help in all-help
                                               collect
                                               (list header help))))
        (handler-case
            (let* ((scanner        (create-scanner regex :case-insensitive-mode t))
                   (actual-fields (loop for field in fields
                                        appending
                                        (when-let* ((header        (first  field))
                                                    (help-commands (second field))
                                                    (filtered-help-commands
                                                     (remove-if-not (make-filter-help-text scanner)
                                                                    help-commands)))
                                          (append (list header)
                                                  filtered-help-commands))))
                   (actual-lines    (mapcar #'help-fields-get-text actual-fields))
                   (no-help-message (list (_ "No command matching your criteria found"))))
              (if (valid-results-p actual-fields)
                  (line-oriented-window:make-blocking-list-dialog-window specials:*main-window*
                                                                         actual-fields
                                                                         actual-lines
                                                                         #'help-expand
                                                                         (_ "Quick help"))
                  (line-oriented-window:make-blocking-list-dialog-window specials:*main-window*
                                                                         '((:text "dummy"))
                                                                         no-help-message
                                                                         (lambda (a b)
                                                                           (declare (ignore a b))))))
          (cl-ppcre:ppcre-syntax-error (e)
            (ui:error-message (format nil
                                      (_ "invalid regular expression ~s ~a")
                                      regex
                                      e))))))))