action-lock.el

   1 ;;; action-lock.el --- invoke magic action by RET key on spell strings
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005-2021
   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 (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   :init-value nil ;; default = off
  72   :lighter action-lock-lighter ;; mode-line
  73   :keymap `(
  74             (,action-lock-magic-return-key . action-lock-magic-return)
  75             )
  76   (if action-lock-mode
  77       (action-lock-initialize-buffer)
  78     (action-lock-restore-buffer)))
  79
  80 (defvar action-lock-rules nil)
  81 (defvar action-lock-original-font-lock-keywords nil)
  82 (defvar action-lock-original-return nil)
  83 (put 'action-lock-rules 'risky-local-variable t)
  84 (put 'action-lock-original-font-lock-keywords 'risky-local-variable t)
  85 (put 'action-lock-original-return 'risky-local-variable t)
  86
  87 (make-variable-buffer-local 'action-lock-rules)
  88 (make-variable-buffer-local 'action-lock-original-font-lock-keywords)
  89 (make-variable-buffer-local 'action-lock-original-return)
  90
  91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92 ;; sample
  93
  94 (defun action-lock-switch (label-list)
  95   (let ((regexp (mapconcat 'regexp-quote label-list "\\|")))
  96 ;   (let ((regexp (regexp-opt label-list))) ;; emacs19 lacks regexp-opt
  97     (list regexp
  98           `(lambda (&optional dummy)
  99              (let* ((b (match-beginning 0))
 100                     (e (match-end 0))
 101                     (ring ',(append label-list (list (car label-list))))
 102                     (s (match-string-no-properties 0))
 103                     (next (cadr (member s ring))))
 104                (delete-region b e)
 105                (insert next)
 106                (goto-char b))))))
 107
 108 (defun action-lock-date (regexp time-format)
 109   (list regexp
 110         `(lambda (&optional dummy)
 111            (delete-region (match-beginning 0) (match-end 0))
 112            (insert (format-time-string ,time-format)))))
 113
 114 (defun action-lock-open (regexp arg-pos &optional hilit-pos)
 115   (action-lock-general #'action-lock-find-file
 116                        regexp arg-pos hilit-pos t))
 117 (defun action-lock-find-file (f u)
 118   (if u
 119       (find-file-other-window f)
 120     (find-file f)))
 121
 122 ;; (defun action-lock-open (regexp arg-pos &optional hilit-pos)
 123 ;;   (action-lock-general #'find-file regexp arg-pos hilit-pos))
 124
 125 (defvar action-lock-no-browser nil)
 126 (defun action-lock-browse-url (url)
 127   (setq url (replace-regexp-in-string "^[htp]+\\(s?\\)://" "http\\1://" url))
 128   (message "%s" url)
 129   (if action-lock-no-browser
 130       (kill-new url)
 131     (browse-url url)))
 132 (defun action-lock-browse (regexp arg-pos &optional hilit-pos)
 133   (action-lock-general #'action-lock-browse-url regexp arg-pos hilit-pos))
 134
 135 (defun action-lock-general (func regexp arg-pos &optional hilit-pos arg-p)
 136   "Generate an action-lock rule.
 137 FUNC is called when action-lock is invoked on a string which matches
 138 to REGEXP. ARG-POS specifies a position of subexpression in REGEXP,
 139 and matched substring is passed to FUNC.
 140 HILIT-POS specifies another position of subexpression in REGEXP,
 141 and matched substring is highlighted in buffers.
 142 FUNC will receive an additional argument for action, as is described
 143 at the beginning of this file, when ARG-P is non-nil."
 144   (list regexp
 145         `(lambda (&optional arg)
 146            (,func (match-string ,arg-pos)
 147                   ,@(and arg-p '(arg))))
 148         hilit-pos))
 149
 150 ; (defun action-lock-escape-quote (s)
 151 ;   (apply 'concat
 152 ;        (mapcar '(lambda (x) (if (string= x "'") "\\x27" x)) ;; for zsh
 153 ;                (split-string s ""))))
 154
 155 ;; copied and modified from thingatpt.el [2004-01-30]
 156 (defvar action-lock-url-path-regexp
 157   "\\([-!@#$%^&*()_+|=:~/?a-zA-Z0-9.,;]*[-!@#$%^&*()_+|=:~/?a-zA-Z0-9]+\\)"
 158 ;;   "\\([^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+\\)"
 159   "A regular expression probably matching the host, path or e-mail part of a URL.")
 160 ;; (defvar action-lock-url-scheme-regexp
 161 ;;   "\\<\\(https?://\\|ftp://\\|gopher://\\|telnet://\\|wais://\\|file:/\\|s?news:\\|mailto:\\)")
 162 (defun action-lock-url-regexp (head &optional tail)
 163   (concat head
 164           action-lock-url-path-regexp
 165           (or tail "")))
 166
 167 (defvar action-lock-open-regexp
 168   (action-lock-url-regexp "\\<file://\\(localhost\\)?\\(" "\\>/?\\)"))
 169 (defvar action-lock-open-regexp-pos 2)
 170
 171 ;; emacs20 doesn't support "[htp]\\{3,5\\}"
 172 (defvar action-lock-browse-regexp
 173   (action-lock-url-regexp "\\<\\([htp][htp][htp][htp]?[htp]?s?\\|ftp\\)://" "\\>/?"))
 174 (defvar action-lock-browse-regexp-pos 0)
 175
 176 (defvar action-lock-default-rules
 177   (list (action-lock-switch action-lock-switch-default)
 178         (action-lock-date (regexp-quote (car action-lock-date-default))
 179                           (cadr action-lock-date-default))
 180         (action-lock-open (action-lock-url-regexp "URL:\\(file://\\)?\\(localhost\\)?" ">))")
 181                           3) ;; ((<URL:...>))
 182         (action-lock-open action-lock-open-regexp
 183                           action-lock-open-regexp-pos) ;; file://...
 184         (action-lock-browse action-lock-browse-regexp
 185                             action-lock-browse-regexp-pos) ;; http://...
 186         ))
 187 (put 'action-lock-default-rules 'risky-local-variable t)
 188
 189 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 190 ;; main
 191
 192 (defvar action-lock-bury-minor-mode-p t)
 193 (defun action-lock-initialize-buffer ()
 194   (interactive)
 195   (action-lock-initialize-magic-return)
 196   (action-lock-set-rules action-lock-default-rules)
 197   (when action-lock-bury-minor-mode-p
 198     (action-lock-bury-minor-mode 'action-lock-mode))
 199 )
 200
 201 (defun action-lock-restore-buffer ()
 202   (action-lock-restore-font-lock))
 203
 204 (defun action-lock-magic-return (&optional arg)
 205   (interactive "P")
 206   (or (action-lock-invoke arg)
 207       (if action-lock-mode
 208           (let* ((action-lock-mode nil)
 209                  (f (key-binding action-lock-magic-return-key)))
 210             (call-interactively f))
 211         ;; Can't happen normally
 212         (call-interactively action-lock-original-return))))
 213
 214 (defun action-lock-invoke (&optional arg)
 215 ;;   (interactive)
 216   (let ((action (action-lock-get-action)))
 217     (if (null action)
 218         nil
 219       (progn
 220 ;;         (message "%s" action) ;; debug
 221         (funcall action arg)
 222 ;;         (apply action nil)
 223         t))))
 224
 225 (defun action-lock-initialize-magic-return ()
 226   (when (null action-lock-original-return)
 227     (let ((action-lock-mode nil))
 228       (setq action-lock-original-return
 229             (key-binding action-lock-magic-return-key)))))
 230
 231 (defun action-lock-rules ()
 232   action-lock-rules)
 233 (defun action-lock-set-rules (rules)
 234   (setq action-lock-rules (howm-cl-remove-duplicates* rules))
 235 ;;   (message "Font lock...")
 236   (action-lock-font-lock)
 237 ;;   (message "...Done.")
 238   )
 239 (defun action-lock-add-rules (rules &optional prepend-p)
 240   (action-lock-set-rules (if prepend-p
 241                              (append rules (action-lock-rules))
 242                            (append (action-lock-rules) rules))))
 243
 244 (defun action-lock-bury-minor-mode (mode)
 245   "Bury MODE to the last in minor-mode-map-alist"
 246   (let ((pair (assoc mode minor-mode-map-alist)))
 247     (when pair
 248       (setq minor-mode-map-alist
 249             ;; Duplications must be removed.
 250             `(,@(remove pair minor-mode-map-alist) ,pair)))))
 251
 252 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 253 ;; Font lock
 254
 255 ;; experimental [2003-10-25]
 256 (defvar action-lock-case-fold-search nil)
 257 (defvar action-lock-use-case-fold-search t)
 258
 259 (defun action-lock-matcher (regexp)
 260   (if action-lock-use-case-fold-search
 261       `(lambda (limit)
 262          (let ((case-fold-search action-lock-case-fold-search))
 263            (re-search-forward ,regexp limit t)))
 264     regexp))
 265
 266 (defun action-lock-font-lock ()
 267   (cheat-font-lock-mode action-lock-silent)
 268   (if (null action-lock-original-font-lock-keywords)
 269       (setq action-lock-original-font-lock-keywords font-lock-keywords)
 270     (setq font-lock-keywords action-lock-original-font-lock-keywords))
 271   (when action-lock-rules
 272     (let* ((entries (mapcar (lambda (pair)
 273                               (let* ((regexp (car pair))
 274                                      (matcher (action-lock-matcher regexp))
 275                                      (pos (or (cl-caddr pair) 0))
 276                                      (hilit (list pos 'action-lock-face
 277                                                   'prepend)))
 278                                 (cons matcher hilit)))
 279                             action-lock-rules)))
 280       (cheat-font-lock-append-keywords entries)
 281 ;;       (cheat-font-lock-prepend-keywords entries)
 282       (cheat-font-lock-fontify t)
 283       )))
 284
 285 (defun action-lock-restore-font-lock ()
 286   (setq font-lock-keywords action-lock-original-font-lock-keywords))
 287
 288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 289
 290 (defun action-lock-get-action ()
 291   (car (action-lock-get-action/range)))
 292
 293 (defun action-lock-get-range ()
 294   (cdr (action-lock-get-action/range)))
 295
 296 (defun action-lock-get-action/range ()
 297   (let* ((rules action-lock-rules)
 298          (current nil)
 299          (found nil))
 300     (while (and rules (not found))
 301       (save-excursion
 302         (setq current (car rules)
 303               rules (cdr rules))
 304         (let* ((regexp (car current))
 305                (action (cadr current))
 306                (pos (cl-caddr current))
 307                (range (action-lock-regexp-range regexp pos)))
 308           (if range
 309               (setq found (cons action range))))))
 310     found))
 311
 312 (defun action-lock-regexp-range (regexp &optional pos)
 313   (setq pos (or pos 0))
 314   (save-excursion
 315     (let ((c (point))
 316           (eol (line-end-position))
 317           (range nil)
 318           (case-fold-search (if action-lock-use-case-fold-search
 319                                 action-lock-case-fold-search
 320                               case-fold-search))
 321           )
 322       (beginning-of-line)
 323       (while (and (<= (point) c)
 324                   (re-search-forward regexp eol 'no-error)
 325                   (not range))
 326         (let ((beg (match-beginning pos))
 327               (end (match-end pos)))
 328           (when (and (<= beg c) (< c end))
 329             (setq range (list beg end)))))
 330       range)))
 331
 332 (defun action-lock-regexp ()
 333   (mapconcat 'car action-lock-rules "\\|"))
 334
 335 (defun action-lock-skip-one-link (reverse)
 336   (let* ((r (action-lock-get-range))
 337          (border (if reverse 0 1)))
 338     (when r
 339       (goto-char (nth border r)))))
 340
 341 (defun action-lock-goto-next-link (&optional reverse)
 342   (interactive)
 343   (let* ((move (if reverse #'backward-char #'forward-char)))
 344     (action-lock-skip-one-link reverse)
 345     (funcall move)
 346     (while (not (action-lock-get-action))
 347       (funcall move))
 348     (when reverse
 349       (action-lock-skip-one-link reverse))))
 350
 351 (defun action-lock-goto-previous-link ()
 352   (interactive)
 353   (action-lock-goto-next-link t))
 354
 355 ;;;;;;;;;;;;;
 356
 357 (provide 'action-lock)
 358
 359 ;;; action-lock.el ends here