branch: elpa/helm
commit 4f0066ac3b36100df2277cdb5afcd29c3ad5af00
Author: Thierry Volpiatto <thie...@posteo.net>
Commit: Thierry Volpiatto <thie...@posteo.net>
Implement diacritics for in buffer sources
Diacritics was only implemented on sync source via the :match slot, as
it is problematic to implement it through this slot in in buffer
sources, we use a specific :diacritics slot in helm-source-in-buffer.
1) Implement matching on match-part with diacritics (helm-core).
2) Make helm-mm-3-search-base aware of diacritics and create a
specific fn for this.
3) Add diacritics slot in helm-source-in-buffer and prepare search
function when the feature is enabled though this slot.
4) Enable it on helm-occur for testing (will make it configurable and
nil by default later).
5) Fix order of match functions when diacritics is enabled.
---
helm-core.el | 12 +++++++-----
helm-multi-match.el | 24 +++++++++++++++++++++---
helm-occur.el | 1 +
helm-source.el | 37 +++++++++++++++++++++++++++++--------
4 files changed, 58 insertions(+), 16 deletions(-)
diff --git a/helm-core.el b/helm-core.el
index ec635732d2..acd4b56738 100644
--- a/helm-core.el
+++ b/helm-core.el
@@ -6443,7 +6443,8 @@ To customize `helm-candidates-in-buffer' behaviour, use
`search',
(defun helm-search-from-candidate-buffer (pattern get-line-fn search-fns
limit start-point
match-part-fn source)
- (let ((inhibit-read-only t))
+ (let ((inhibit-read-only t)
+ (diacritics (assoc-default 'diacritics source)))
(helm--search-from-candidate-buffer-1
(lambda ()
(cl-loop with hash = (make-hash-table :test 'equal)
@@ -6498,14 +6499,14 @@ To customize `helm-candidates-in-buffer' behaviour, use
`search',
;; returns a cons cell, collect PATTERN
only if it
;; match the part of CAND specified by
;; the match-part func.
- (helm-search-match-part cand pattern)))
+ (helm-search-match-part cand pattern
diacritics)))
do (progn
(puthash cand iter hash)
(helm--maybe-process-filter-one-by-one-candidate
cand source)
(cl-incf count))
and collect cand))))))
-(defun helm-search-match-part (candidate pattern)
+(defun helm-search-match-part (candidate pattern diacritics)
"Match PATTERN only on match-part property value of CANDIDATE.
Because `helm-search-match-part' may be called even if
@@ -6515,8 +6516,9 @@ computed by match-part-fn and stored in the match-part
property."
(let ((part (or (get-text-property 0 'match-part candidate)
candidate))
(fuzzy-regexp (cadr (gethash 'helm-pattern helm--fuzzy-regexp-cache)))
- (matchfn (if helm-migemo-mode
- 'helm-mm-migemo-string-match 'string-match)))
+ (matchfn (cond (helm-migemo-mode 'helm-mm-migemo-string-match)
+ (diacritics 'helm-mm-diacritics-string-match)
+ (t 'string-match))))
(if (string-match " " pattern)
(cl-loop for i in (helm-mm-split-pattern pattern) always
(if (string-match "\\`!" i)
diff --git a/helm-multi-match.el b/helm-multi-match.el
index b848c09cce..559c3feb9c 100644
--- a/helm-multi-match.el
+++ b/helm-multi-match.el
@@ -245,19 +245,30 @@ i.e (identity (re-search-forward \"foo\" (point-at-eol)
t)) => t."
(cl-loop with pat = (if (stringp pattern)
(helm-mm-3-get-patterns pattern)
pattern)
+ with regex = (cdar pat)
+ with regex1 = (if (and regex
+ (not (helm-mm-regexp-p regex))
+ helm-mm--match-on-diacritics)
+ (char-fold-to-regexp regex)
+ regex)
when (eq (caar pat) 'not) return
;; Pass the job to `helm-search-match-part'.
(prog1 (list (point-at-bol) (point-at-eol))
(forward-line 1))
while (condition-case _err
- (funcall searchfn1 (or (cdar pat) "") nil t)
+ (funcall searchfn1 (or regex1 "") nil t)
(invalid-regexp nil))
for bol = (point-at-bol)
for eol = (point-at-eol)
- if (cl-loop for (pred . str) in (cdr pat) always
+ if (cl-loop for (pred . str) in (cdr pat)
+ for regexp = (if (and (not (helm-mm-regexp-p str))
+ helm-mm--match-on-diacritics)
+ (char-fold-to-regexp str)
+ str)
+ always
(progn (goto-char bol)
(funcall pred (condition-case _err
- (funcall searchfn2 str eol t)
+ (funcall searchfn2 regexp eol
t)
(invalid-regexp nil)))))
do (goto-char eol) and return t
else do (goto-char eol)
@@ -266,6 +277,10 @@ i.e (identity (re-search-forward \"foo\" (point-at-eol)
t)) => t."
(defun helm-mm-3-search (pattern &rest _ignore)
(helm-mm-3-search-base
pattern 're-search-forward 're-search-forward))
+
+(defun helm-mm-3-search-on-diacritics (pattern &rest _ignore)
+ (let ((helm-mm--match-on-diacritics t))
+ (helm-mm-3-search pattern)))
;;; mp-3 with migemo
;; Needs https://github.com/emacs-jp/migemo
@@ -306,6 +321,9 @@ i.e. the sources which have the slot :migemo with non--nil
value."
helm-mm--previous-migemo-info))))
(string-match (assoc-default pattern helm-mm--previous-migemo-info) str))
+(defun helm-mm-diacritics-string-match (pattern str)
+ (string-match (char-fold-to-regexp pattern) str))
+
(cl-defun helm-mm-3-migemo-match (candidate &optional (pattern helm-pattern))
(and helm-migemo-mode
(cl-loop for (pred . re) in (helm-mm-3-get-patterns pattern)
diff --git a/helm-occur.el b/helm-occur.el
index 7880df5e7f..bf60561dfd 100644
--- a/helm-occur.el
+++ b/helm-occur.el
@@ -290,6 +290,7 @@ engine beeing completely different and also much faster."
(when (string-match helm-occur--search-buffer-regexp
candidate)
(match-string 2 candidate)))
+ :diacritics t
:search (lambda (pattern)
(when (string-match "\\`\\^\\([^ ]*\\)" pattern)
(setq pattern (concat "^[0-9]* \\{1\\}" (match-string
1 pattern))))
diff --git a/helm-source.el b/helm-source.el
index 0325598c99..2f5bf9ace8 100644
--- a/helm-source.el
+++ b/helm-source.el
@@ -823,6 +823,13 @@ inherit from `helm-source'.")
(match
:initform '(identity))
+ (diacritics
+ :initarg :diacritics
+ :initform nil
+ :custom boolean
+ :documentation
+ " Ignore diacritics when searching.")
+
(get-line
:initarg :get-line
:initform 'buffer-substring-no-properties
@@ -978,10 +985,11 @@ Arguments ARGS are keyword value pairs as defined in
CLASS."
(defvar helm-mm-default-match-functions)
(defun helm-source-mm-get-search-or-match-fns (source method)
- (let* (diacritics
+ (let* ((diacritics (cl-case method
+ (match (eq (slot-value source 'match) 'diacritics))
+ (search (slot-value source 'diacritics))))
(defmatch (helm-aif (slot-value source 'match)
- (unless (setq diacritics (eq it 'diacritics))
- (helm-mklist it))))
+ (unless diacritics (helm-mklist it))))
(defmatch-strict (helm-aif (and (eq method 'match)
(slot-value source 'match-strict))
(helm-mklist it)))
@@ -994,20 +1002,33 @@ Arguments ARGS are keyword value pairs as defined in
CLASS."
(migemo (slot-value source 'migemo)))
(cl-case method
(match (cond (defmatch-strict)
+ ((and migemo diacritics)
+ (append (list 'helm-mm-exact-match
+ 'helm-mm-3-match-on-diacritics)
+ defmatch '(helm-mm-3-migemo-match)))
(migemo
(append helm-mm-default-match-functions
defmatch '(helm-mm-3-migemo-match)))
- (defmatch
+ ((and defmatch (not diacritics))
(append helm-mm-default-match-functions defmatch))
- (t (if diacritics
- (list 'helm-mm-exact-match
'helm-mm-3-match-on-diacritics)
- helm-mm-default-match-functions))))
+ (diacritics
+ (append (list 'helm-mm-exact-match
+ 'helm-mm-3-match-on-diacritics)))
+ (t helm-mm-default-match-functions)))
(search (cond (defsearch-strict)
+ ((and migemo diacritics)
+ (append '(helm-mm-exact-search)
+ defsearch
+ '(helm-mm-3-migemo-search
+ helm-mm-3-search-on-diacritics)))
(migemo
(append helm-mm-default-search-functions
defsearch '(helm-mm-3-migemo-search)))
- (defsearch
+ ((and defsearch (not diacritics))
(append helm-mm-default-search-functions defsearch))
+ (diacritics
+ `(helm-mm-exact-search
+ ,@defsearch helm-mm-3-search-on-diacritics))
(t helm-mm-default-search-functions))))))
