action-lock.el

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