action-lock.el

   1 ;;; action-lock.el --- invoke magic action by RET key on spell strings
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005-2020
   4 ;;   HIRAOKA Kazuyuki <khi@users.osdn.me>
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 1, or (at your option)
   9 ;; any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; The GNU General Public License is available by anonymouse ftp from
  17 ;; prep.ai.mit.edu in pub/gnu/COPYING.  Alternately, you can write to
  18 ;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
  19 ;; USA.
  20
  21 ;;; Commentary:
  22
  23 ;;; Code:
  24
  25 ;; rules = (rule rule ...)
  26 ;; rule = (regexp action) or (regexp action hilit-pos)
  27 ;; action = function with one argument which corresponds to (interactive "P").
  28
  29 (require 'cl-lib)
  30 (require 'easy-mmode)
  31 (require 'font-lock)
  32 (require 'cheat-font-lock)
  33 (require 'howm-common)
  34
  35 (defgroup action-lock nil
  36   "Invoke magic action by RET key on spell strings."
  37   :group 'convenience)
  38
  39 (defvar action-lock-face 'action-lock-face
  40   "*Face for action-lock spells.")
  41
  42 (defface action-lock-face
  43   (let ((underline (if (and (fboundp 'set-face-underline)
  44                             window-system)
  45                        '(((class color)) (:underline "dark cyan"))
  46                      '(((class color)) (:underline t))))
  47         (fail-safe '(t (:inverse-video t))))
  48     (list underline fail-safe))
  49   "*Face for action-lock spells."
  50   :group 'action-lock
  51   :group 'howm-faces)
  52
  53 (defvar action-lock-magic-return-key "\C-m")
  54 (put 'action-lock-magic-return-key 'risky-local-variable t)
  55 (defvar action-lock-lighter " AL")
  56 (defvar action-lock-silent t
  57   "Inhibit font-lock-verbose if non-nil.")
  58
  59 ;; If you want to change these values,
  60 ;; you must set them before loading this file.
  61 (defvar action-lock-switch-default '("{ }" "{*}" "{-}"))  ;; any number
  62 (defvar action-lock-date-default '("{_}" "[%Y-%m-%d %H:%M]"))  ;; before after
  63
  64 (easy-mmode-define-minor-mode action-lock-mode
  65   "With no argument, this command toggles the mode.
  66 Non-null prefix argument turns on the mode.
  67 Null prefix argument turns off the mode.
  68
  69 \\[action-lock-magic-return]  Envoke the action on the field
  70 "
  71   nil ;; default = off
  72   action-lock-lighter ;; mode-line
  73   `(
  74     (,action-lock-magic-return-key . action-lock-magic-return)
  75     ))
  76
  77 ;; emacs20's easy-mmode-define-minor-mode can't have body. sigh...
  78 (add-hook 'action-lock-mode-on-hook 'action-lock-initialize-buffer)
  79 (add-hook 'action-lock-mode-off-hook 'action-lock-restore-buffer)
  80
  81 (defvar action-lock-rules nil)
  82 (defvar action-lock-original-font-lock-keywords nil)
  83 (defvar action-lock-original-return nil)
  84 (put 'action-lock-rules 'risky-local-variable t)
  85 (put 'action-lock-original-font-lock-keywords 'risky-local-variable t)
  86 (put 'action-lock-original-return 'risky-local-variable t)
  87
  88 (make-variable-buffer-local 'action-lock-rules)
  89 (make-variable-buffer-local 'action-lock-original-font-lock-keywords)
  90 (make-variable-buffer-local 'action-lock-original-return)
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93 ;; sample
  94
  95 (defun action-lock-switch (label-list)
  96   (let ((regexp (mapconcat 'regexp-quote label-list "\\|")))
  97 ;   (let ((regexp (regexp-opt label-list))) ;; emacs19 lacks regexp-opt
  98     (list regexp
  99           `(lambda (&optional dummy)
 100              (let* ((b (match-beginning 0))
 101                     (e (match-end 0))
 102                     (ring ',(append label-list (list (car label-list))))
 103                     (s (match-string-no-properties 0))
 104                     (next (cadr (member s ring))))
 105                (delete-region b e)
 106                (insert next)
 107                (goto-char b))))))
 108
 109 (defun action-lock-date (regexp time-format)
 110   (list regexp
 111         `(lambda (&optional dummy)
 112            (delete-region (match-beginning 0) (match-end 0))
 113            (insert (format-time-string ,time-format)))))
 114
 115 (defun action-lock-open (regexp arg-pos &optional hilit-pos)
 116   (action-lock-general #'action-lock-find-file
 117                        regexp arg-pos hilit-pos t))
 118 (defun action-lock-find-file (f u)
 119   (if u
 120       (find-file-other-window f)
 121     (find-file f)))
 122
 123 ;; (defun action-lock-open (regexp arg-pos &optional hilit-pos)
 124 ;;   (action-lock-general #'find-file regexp arg-pos hilit-pos))
 125
 126 (defvar action-lock-no-browser nil)
 127 (defun action-lock-browse-url (url)
 128   (setq url (replace-regexp-in-string "^[htp]+\\(s?\\)://" "http\\1://" url))
 129   (message "%s" url)
 130   (if action-lock-no-browser
 131       (kill-new url)
 132     (browse-url url)))
 133 (defun action-lock-browse (regexp arg-pos &optional hilit-pos)
 134   (action-lock-general #'action-lock-browse-url regexp arg-pos hilit-pos))
 135
 136 (defun action-lock-general (func regexp arg-pos &optional hilit-pos arg-p)
 137   "Generate an action-lock rule.
 138 FUNC is called when action-lock is invoked on a string which matches
 139 to REGEXP. ARG-POS specifies a position of subexpression in REGEXP,
 140 and matched substring is passed to FUNC.
 141 HILIT-POS specifies another position of subexpression in REGEXP,
 142 and matched substring is highlighted in buffers.
 143 FUNC will receive an additional argument for action, as is described
 144 at the beginning of this file, when ARG-P is non-nil."
 145   (list regexp
 146         `(lambda (&optional arg)
 147            (,func (match-string ,arg-pos)
 148                   ,@(and arg-p '(arg))))
 149         hilit-pos))
 150
 151 ; (defun action-lock-escape-quote (s)
 152 ;   (apply 'concat
 153 ;        (mapcar '(lambda (x) (if (string= x "'") "\\x27" x)) ;; for zsh
 154 ;                (split-string s ""))))
 155
 156 ;; copied and modified from thingatpt.el [2004-01-30]
 157 (defvar action-lock-url-path-regexp
 158   "\\([-!@#$%^&*()_+|=:~/?a-zA-Z0-9.,;]*[-!@#$%^&*()_+|=:~/?a-zA-Z0-9]+\\)"
 159 ;;   "\\([^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+\\)"
 160   "A regular expression probably matching the host, path or e-mail part of a URL.")
 161 ;; (defvar action-lock-url-scheme-regexp
 162 ;;   "\\<\\(https?://\\|ftp://\\|gopher://\\|telnet://\\|wais://\\|file:/\\|s?news:\\|mailto:\\)")
 163 (defun action-lock-url-regexp (head &optional tail)
 164   (concat head
 165           action-lock-url-path-regexp
 166           (or tail "")))
 167
 168 (defvar action-lock-open-regexp
 169   (action-lock-url-regexp "\\<file://\\(localhost\\)?\\(" "\\>/?\\)"))
 170 (defvar action-lock-open-regexp-pos 2)
 171
 172 ;; emacs20 doesn't support "[htp]\\{3,5\\}"
 173 (defvar action-lock-browse-regexp
 174   (action-lock-url-regexp "\\<\\([htp][htp][htp][htp]?[htp]?s?\\|ftp\\)://" "\\>/?"))
 175 (defvar action-lock-browse-regexp-pos 0)
 176
 177 (defvar action-lock-default-rules
 178   (list (action-lock-switch action-lock-switch-default)
 179         (action-lock-date (regexp-quote (car action-lock-date-default))
 180                           (cadr action-lock-date-default))
 181         (action-lock-open (action-lock-url-regexp "URL:\\(file://\\)?\\(localhost\\)?" ">))")
 182                           3) ;; ((<URL:...>))
 183         (action-lock-open action-lock-open-regexp
 184                           action-lock-open-regexp-pos) ;; file://...
 185         (action-lock-browse action-lock-browse-regexp
 186                             action-lock-browse-regexp-pos) ;; http://...
 187         ))
 188 (put 'action-lock-default-rules 'risky-local-variable t)
 189
 190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 191 ;; main
 192
 193 (defvar action-lock-bury-minor-mode-p t)
 194 (defun action-lock-initialize-buffer ()
 195   (interactive)
 196   (action-lock-initialize-magic-return)
 197   (action-lock-set-rules action-lock-default-rules)
 198   (when action-lock-bury-minor-mode-p
 199     (action-lock-bury-minor-mode 'action-lock-mode))
 200 )
 201
 202 (defun action-lock-restore-buffer ()
 203   (action-lock-restore-font-lock))
 204
 205 (defun action-lock-magic-return (&optional arg)
 206   (interactive "P")
 207   (or (action-lock-invoke arg)
 208       (if action-lock-mode
 209           (let* ((action-lock-mode nil)
 210                  (f (key-binding action-lock-magic-return-key)))
 211             (call-interactively f))
 212         ;; Can't happen normally
 213         (call-interactively action-lock-original-return))))
 214
 215 (defun action-lock-invoke (&optional arg)
 216 ;;   (interactive)
 217   (let ((action (action-lock-get-action)))
 218     (if (null action)
 219         nil
 220       (progn
 221 ;;         (message "%s" action) ;; debug
 222         (funcall action arg)
 223 ;;         (apply action nil)
 224         t))))
 225
 226 (defun action-lock-initialize-magic-return ()
 227   (when (null action-lock-original-return)
 228     (let ((action-lock-mode nil))
 229       (setq action-lock-original-return
 230             (key-binding action-lock-magic-return-key)))))
 231
 232 (defun action-lock-rules ()
 233   action-lock-rules)
 234 (defun action-lock-set-rules (rules)
 235   (setq action-lock-rules (howm-cl-remove-duplicates* rules))
 236 ;;   (message "Font lock...")
 237   (action-lock-font-lock)
 238 ;;   (message "...Done.")
 239   )
 240 (defun action-lock-add-rules (rules &optional prepend-p)
 241   (action-lock-set-rules (if prepend-p
 242                              (append rules (action-lock-rules))
 243                            (append (action-lock-rules) rules))))
 244
 245 (defun action-lock-bury-minor-mode (mode)
 246   "Bury MODE to the last in minor-mode-map-alist"
 247   (let ((pair (assoc mode minor-mode-map-alist)))
 248     (when pair
 249       (setq minor-mode-map-alist
 250             ;; Duplications must be removed.
 251             `(,@(remove pair minor-mode-map-alist) ,pair)))))
 252
 253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 254 ;; Font lock
 255
 256 ;; experimental [2003-10-25]
 257 (defvar action-lock-case-fold-search nil)
 258 (defvar action-lock-use-case-fold-search t)
 259
 260 (defun action-lock-matcher (regexp)
 261   (if action-lock-use-case-fold-search
 262       `(lambda (limit)
 263          (let ((case-fold-search action-lock-case-fold-search))
 264            (re-search-forward ,regexp limit t)))
 265     regexp))
 266
 267 (defun action-lock-font-lock ()
 268   (cheat-font-lock-mode action-lock-silent)
 269   (if (null action-lock-original-font-lock-keywords)
 270       (setq action-lock-original-font-lock-keywords font-lock-keywords)
 271     (setq font-lock-keywords action-lock-original-font-lock-keywords))
 272   (when action-lock-rules
 273     (let* ((entries (mapcar (lambda (pair)
 274                               (let* ((regexp (car pair))
 275                                      (matcher (action-lock-matcher regexp))
 276                                      (pos (or (cl-caddr pair) 0))
 277                                      (hilit (list pos 'action-lock-face
 278                                                   'prepend)))
 279                                 (cons matcher hilit)))
 280                             action-lock-rules)))
 281       (cheat-font-lock-append-keywords entries)
 282 ;;       (cheat-font-lock-prepend-keywords entries)
 283       (cheat-font-lock-fontify t)
 284       )))
 285
 286 (defun action-lock-restore-font-lock ()
 287   (setq font-lock-keywords action-lock-original-font-lock-keywords))
 288
 289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 290
 291 (defun action-lock-get-action ()
 292   (car (action-lock-get-action/range)))
 293
 294 (defun action-lock-get-range ()
 295   (cdr (action-lock-get-action/range)))
 296
 297 (defun action-lock-get-action/range ()
 298   (let* ((rules action-lock-rules)
 299          (current nil)
 300          (found nil))
 301     (while (and rules (not found))
 302       (save-excursion
 303         (setq current (car rules)
 304               rules (cdr rules))
 305         (let* ((regexp (car current))
 306                (action (cadr current))
 307                (pos (cl-caddr current))
 308                (range (action-lock-regexp-range regexp pos)))
 309           (if range
 310               (setq found (cons action range))))))
 311     found))
 312
 313 (defun action-lock-regexp-range (regexp &optional pos)
 314   (setq pos (or pos 0))
 315   (save-excursion
 316     (let ((c (point))
 317           (eol (line-end-position))
 318           (range nil)
 319           (case-fold-search (if action-lock-use-case-fold-search
 320                                 action-lock-case-fold-search
 321                               case-fold-search))
 322           )
 323       (beginning-of-line)
 324       (while (and (<= (point) c)
 325                   (re-search-forward regexp eol 'no-error)
 326                   (not range))
 327         (let ((beg (match-beginning pos))
 328               (end (match-end pos)))
 329           (when (and (<= beg c) (< c end))
 330             (setq range (list beg end)))))
 331       range)))
 332
 333 (defun action-lock-regexp ()
 334   (mapconcat 'car action-lock-rules "\\|"))
 335
 336 (defun action-lock-skip-one-link (reverse)
 337   (let* ((r (action-lock-get-range))
 338          (border (if reverse 0 1)))
 339     (when r
 340       (goto-char (nth border r)))))
 341
 342 (defun action-lock-goto-next-link (&optional reverse)
 343   (interactive)
 344   (let* ((move (if reverse #'backward-char #'forward-char)))
 345     (action-lock-skip-one-link reverse)
 346     (funcall move)
 347     (while (not (action-lock-get-action))
 348       (funcall move))
 349     (when reverse
 350       (action-lock-skip-one-link reverse))))
 351
 352 (defun action-lock-goto-previous-link ()
 353   (interactive)
 354   (action-lock-goto-next-link t))
 355
 356 ;;;;;;;;;;;;;
 357
 358 (provide 'action-lock)
 359
 360 ;;; action-lock.el ends here