meow-thing.el

;;; meow-thing.el --- Calculate bounds of thing in Meow  -*- lexical-binding: t -*-

;; This file is not part of GNU Emacs.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

(require 'cl-lib)
(require 'subr-x)

(require 'meow-var)
(require 'meow-util)

(defun meow--bounds-of-symbol ()
  (when-let (bounds (bounds-of-thing-at-point 'symbol))
    (let ((beg (car bounds))
          (end (cdr bounds)))
      (save-mark-and-excursion
        (goto-char end)
        (if (not (looking-at-p "\\s)"))
            (while (looking-at-p " \\|,")
              (goto-char (cl-incf end)))
          (goto-char beg)
          (while (looking-back " \\|," 1)
            (goto-char (cl-decf beg))))
        (cons beg end)))))

(defun meow--bounds-of-string-1 ()
  "Return the bounds of the string under the cursor.

The thing `string' is not available in Emacs 27.'"
  (if (version< emacs-version "28")
      (when (meow--in-string-p)
        (let (beg end)
          (save-mark-and-excursion
            (while (meow--in-string-p)
              (backward-char 1))
            (setq beg (point)))
          (save-mark-and-excursion
            (while (meow--in-string-p)
              (forward-char 1))
            (setq end (point)))
          (cons beg end)))
    (bounds-of-thing-at-point 'string)))

(defun meow--inner-of-symbol ()
  (bounds-of-thing-at-point 'symbol))

(defun meow--bounds-of-string (&optional inner)
  (when-let (bounds (meow--bounds-of-string-1))
    (let ((beg (car bounds))
          (end (cdr bounds)))
      (cons
       (save-mark-and-excursion
         (goto-char beg)
         (funcall (if inner #'skip-syntax-forward #'skip-syntax-backward) "\"|")
         (point))
       (save-mark-and-excursion
         (goto-char end)
         (funcall (if inner #'skip-syntax-backward #'skip-syntax-forward) "\"|")
         (point))))))

(defun meow--inner-of-string ()
  (meow--bounds-of-string t))

(defun meow--inner-of-window ()
  (cons (window-start) (window-end)))

(defun meow--inner-of-line ()
  (cons (save-mark-and-excursion (back-to-indentation) (point))
        (line-end-position)))

(defun meow--inner-of-visual-line ()
  (cons (meow--visual-line-beginning-position)
        (meow--visual-line-end-position)))

;;; Registry

(defvar meow--thing-registry nil
  "Thing registry.

This is a plist mapping from thing to (inner-fn . bounds-fn).
Both inner-fn and bounds-fn returns a cons of (start . end) for that thing.")

(defun meow--thing-register (thing inner-fn bounds-fn)
  "Register INNER-FN and BOUNDS-FN to a THING."
  (setq meow--thing-registry
        (plist-put meow--thing-registry
                   thing
                   (cons inner-fn bounds-fn))))

(defun meow--thing-syntax-function (syntax)
  (cons
   (save-mark-and-excursion
     (when (use-region-p)
       (goto-char (region-beginning)))
     (skip-syntax-backward (cdr syntax))
     (point))
   (save-mark-and-excursion
     (when (use-region-p)
       (goto-char (region-end)))
     (skip-syntax-forward (cdr syntax))
     (point))))

(defun meow--thing-regexp-function (b-re f-re near)
  (let ((beg (save-mark-and-excursion
               (when (use-region-p)
                 (goto-char (region-beginning)))
               (when (re-search-backward b-re nil t)
                 (if near (match-end 0) (point)))))
        (end (save-mark-and-excursion
               (when (use-region-p)
                 (goto-char (region-end)))
               (when (re-search-forward f-re nil t)
                 (if near (match-beginning 0) (point))))))
    (when (and beg end)
      (cons beg end))))

(defun meow--thing-parse-pair-search (push-token pop-token back near)
  (let* ((search-fn (if back #'re-search-backward #'re-search-forward))
         (match-fn (if back #'match-end #'match-beginning))
         (cmp-fn (if back #'> #'<))
         (push-next-pos nil)
         (pop-next-pos nil)
         (push-pos (save-mark-and-excursion
                     (when (funcall search-fn push-token nil t)
                       (setq push-next-pos (point))
                       (if near (funcall match-fn 0) (point)))))
         (pop-pos (save-mark-and-excursion
                    (when (funcall search-fn pop-token nil t)
                      (setq pop-next-pos (point))
                      (if near (funcall match-fn 0) (point))))))
    (cond
     ((and (not pop-pos) (not push-pos))
      nil)
     ((not pop-pos)
      (goto-char push-next-pos)
      (cons 'push push-pos))
     ((not push-pos)
      (goto-char pop-next-pos)
      (cons 'pop pop-pos))
     ((funcall cmp-fn push-pos pop-pos)
      (goto-char push-next-pos)
      (cons 'push push-pos))
     (t
      (goto-char pop-next-pos)
      (cons 'pop pop-pos)))))

(defun meow--thing-pair-function (push-token pop-token near)
  (let* ((found nil)
         (depth  0)
         (beg (save-mark-and-excursion
                (prog1
                    (let ((case-fold-search nil))
                      (while (and (<= depth 0)
                                  (setq found (meow--thing-parse-pair-search push-token pop-token t near)))
                        (let ((push-or-pop (car found)))
                          (if (eq 'push push-or-pop)
                              (cl-incf depth)
                            (cl-decf depth))))
                      (when (> depth 0) (cdr found)))
                  (setq depth 0
                        found nil))))
         (end (save-mark-and-excursion
                (let ((case-fold-search nil))
                  (while (and (>= depth 0)
                              (setq found (meow--thing-parse-pair-search push-token pop-token nil near)))
                    (let ((push-or-pop (car found)))
                      (if (eq 'push push-or-pop)
                          (cl-incf depth)
                        (cl-decf depth))))
                  (when (< depth 0) (cdr found))))))
    (when (and beg end)
      (cons beg end))))


(defun meow--thing-make-syntax-function (x)
  (lambda () (meow--thing-syntax-function x)))

(defun meow--thing-make-regexp-function (x near)
  (let* ((b-re (cadr x))
         (f-re (caddr x)))
    (lambda () (meow--thing-regexp-function b-re f-re near))))

(defun meow--thing-make-pair-function (x near)
  (let* ((push-token (let ((tokens (cadr x)))
                       (string-join (mapcar #'regexp-quote tokens) "\\|")))
         (pop-token (let ((tokens (caddr x)))
                      (string-join (mapcar #'regexp-quote tokens) "\\|"))))
    (lambda () (meow--thing-pair-function push-token pop-token near))))

(defun meow--thing-parse-multi (xs near)
  (let ((chained-fns (mapcar (lambda (x) (meow--thing-parse x near)) xs)))
    (lambda ()
      (let ((fns chained-fns)
            ret)
        (while (and fns (not ret))
          (setq ret (funcall (car fns))
                fns (cdr fns)))
        ret))))

(defun meow--thing-parse (x near)
  (cond
   ((functionp x)
    x)
   ((symbolp x)
    (lambda () (bounds-of-thing-at-point x)))
   ((equal 'syntax (car x))
    (meow--thing-make-syntax-function x))
   ((equal 'regexp (car x))
    (meow--thing-make-regexp-function x near))
   ((equal 'pair (car x))
    (meow--thing-make-pair-function x near))
   ((listp x)
    (meow--thing-parse-multi x near))
   (t
    (lambda ()
      (message "Meow: THING definition broken")
      (cons (point) (point))))))

(defun meow-thing-register (thing inner bounds)
  "Register a THING with INNER and BOUNDS.

Argument THING should be symbol, which specified in `meow-char-thing-table'.
Argument INNER and BOUNDS support following expressions:

  EXPR ::= FUNCTION | SYMBOL | SYNTAX-EXPR | REGEXP-EXPR
         | PAIRED-EXPR | MULTI-EXPR
  SYNTAX-EXPR ::= (syntax . STRING)
  REGEXP-EXPR ::= (regexp STRING STRING)
  PAIRED-EXPR ::= (pair TOKENS TOKENS)
  MULTI-EXPR ::= (EXPR ...)
  TOKENS ::= (STRING ...)

FUNCTION is a function receives no arguments, return a cons which
  the car is the beginning of thing, and the cdr is the end of
  thing.

SYMBOL is a symbol represent a builtin thing.

  Example: url

    (meow-thing-register 'url 'url 'url)

SYNTAX-EXPR contains a syntax description used by `skip-syntax-forward'

  Example: non-whitespaces

    (meow-thing-register 'non-whitespace
                         '(syntax . \"^-\")
                         '(syntax . \"^-\"))

  You can find the description for syntax in current buffer with
  \\[describe-syntax].

REGEXP-EXPR contains two regexps, the first is used for
  beginning, the second is used for end. For inner/beginning/end
  function, the point of near end of match will be used.  For
  bounds function, the point of far end of match will be used.

  Example: quoted

    (meow-thing-register 'quoted
                         '(regexp \"`\" \"`\\\\|'\")
                         '(regexp \"`\" \"`\\\\|'\"))

PAIR-EXPR contains two string token lists. The tokens in first
  list are used for finding beginning, the tokens in second list
  are used for finding end.  A depth variable will be used while
  searching, thus only matched pair will be found.

  Example: do/end block

    (meow-thing-register 'do/end
                         '(pair (\"do\") (\"end\"))
                         '(pair (\"do\") (\"end\")))"
    (let ((inner-fn (meow--thing-parse inner t))
          (bounds-fn (meow--thing-parse bounds nil)))
      (meow--thing-register thing inner-fn bounds-fn)))

(meow-thing-register 'round
                     '(pair ("(") (")"))
                     '(pair ("(") (")")))

(meow-thing-register 'square
                     '(pair ("[") ("]"))
                     '(pair ("[") ("]")))

(meow-thing-register 'curly
                     '(pair ("{") ("}"))
                     '(pair ("{") ("}")))

(meow-thing-register 'paragraph 'paragraph 'paragraph)

(meow-thing-register 'sentence 'sentence 'sentence)

(meow-thing-register 'buffer 'buffer 'buffer)

(meow-thing-register 'defun 'defun 'defun)

(meow-thing-register 'symbol #'meow--inner-of-symbol #'meow--bounds-of-symbol)

(meow-thing-register 'string #'meow--inner-of-string #'meow--bounds-of-string)

(meow-thing-register 'window #'meow--inner-of-window #'meow--inner-of-window)

(meow-thing-register 'line #'meow--inner-of-line 'line)

(meow-thing-register 'visual-line #'meow--inner-of-visual-line #'meow--inner-of-visual-line)

(defun meow--parse-inner-of-thing-char (ch)
  (when-let ((ch-to-thing (assoc ch meow-char-thing-table)))
    (meow--parse-range-of-thing (cdr ch-to-thing) t)))

(defun meow--parse-bounds-of-thing-char (ch)
  (when-let ((ch-to-thing (assoc ch meow-char-thing-table)))
    (meow--parse-range-of-thing (cdr ch-to-thing) nil)))

(defun meow--parse-range-of-thing (thing inner)
  "Parse either inner or bounds of THING. If INNER is non-nil then parse inner."
  (when-let (bounds-fn-pair (plist-get meow--thing-registry thing))
    (if inner
        (funcall (car bounds-fn-pair))
      (funcall (cdr bounds-fn-pair)))))

(provide 'meow-thing)
;;; meow-thing.el ends here