プッシュボタンが連打できなくて修正しようとしたらドハマリして時間を大量に無駄にしたのでメモ。

Widgetライブラリのpush-buttonを連打しようとするとダブルクリックやトリプルクリックと判定されてボタンが押せなくなります。そしてなぜか範囲選択が始まったりします。「+」「-」とか「Previous」「Next」等をプッシュボタンにすると連打できないのはとても気になるので何とかしました。

次のコードは何とかしたカウンターアプリケーションの例です。 M-x my-count で単純なカウンターが動きます。

(require 'widget)

;; ダブルクリック、トリプルクリックに対応した `widget-button-click' の代わりです。
(defun my-widget-button-click (event)
  (interactive "e")
  ;; Add double and triple click support to widget-button-release-event-p
  (cl-letf (((symbol-function 'widget-button-release-event-p)
             'my-widget-button-release-event-p))
    (widget-button-click event)))

;; ダブルクリック、トリプルクリックに対応した `my-widget-button-release-event-p' の代わりです。
(defun my-widget-button-release-event-p (event)
  (and (eventp event)
       (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3))
       (or (and (or (memq 'double (event-modifiers event)) ;;double click
                    (memq 'triple (event-modifiers event))) ;;triple click
                (null (memq 'down (event-modifiers event))))
           (memq 'click (event-modifiers event))
           (memq 'drag (event-modifiers event)))))

(defvar my-push-button-map
  (let ((km (make-sparse-keymap)))
    (define-key km [drag-mouse-1] 'ignore)
    (define-key km [double-down-mouse-1] 'my-widget-button-click)
    (define-key km [triple-down-mouse-1] 'my-widget-button-click)
    km))


(defvar-local my-number-widget nil)
(defun my-increase (delta)
  (widget-value-set
   my-number-widget
   (+ (widget-value my-number-widget) delta)))
(defun my-inc (&rest _) (my-increase 1))
(defun my-dec (&rest _) (my-increase -1))

(defun my-counter ()
  (interactive)
  (pop-to-buffer "*my counter*")
  (kill-all-local-variables)
  (let ((inhibit-read-only t))
    (erase-buffer))
  (remove-overlays)
  (setq-local my-number-widget
              (widget-create 'number
                             :size 10
                             :value 0))
  (widget-insert " ")
  (widget-create 'push-button
                 :notify 'my-dec
                 :keymap my-push-button-map ;;support double and triple down
                 "Decrement")
  (widget-insert " ")
  (widget-create 'push-button
                 :notify 'my-inc
                 :keymap my-push-button-map ;;support double and triple down
                 "Increment")
  (widget-insert "\n")
  (use-local-map widget-keymap)
  (widget-setup)
  (widget-forward 1))

問題の原因は次の二点にありました。

• ダブル、トリプルクリックのキーマップが割り当てられていないこと
• マウスのボタンが離されたことを判定する関数がダブル、トリプルクリックに対応していないこと

プッシュボタンの処理はローカルマップのdown-mouse-1に割り当てられたwidget-button-click関数によって行われています。その中では押された位置のボタンを割り出して、ボタンが離されるまで追跡し、ボタンに関連付けられたアクションを実行します。途中でキャンセルされたらグローバルマップのマウスイベントに割り当てられたコマンドを実行します。

ローカルマップのdouble-down-mouse-1とtriple-down-mouse-1にwidget-button-clickが割り当てられていないのが問題なのだと思い割り当てたのですが変わりませんでした。

widget-button-click関数の中ではwidget-button-release-event-pという関数を呼んでいてイベントがマウスボタンを離したものかを判定しています。そこがclickとdragのみを考慮していてdoubleやtripleを考慮していません。なのでボタンを離しても離されていないものとしてずっと追跡を続けてしまっていました。

上の例ではcl-letfを使用してダブルクリック、トリプルクリックが発生したときだけwidget-button-release-event-pの中身を入れ替えることで対処しています。従ってwidgetライブラリ内の構造が変わると動かなくなるかもしれません。

以上ですが、誰得情報なんだこれ。

先日からEmacsの中で動く作図ツールを作っています。

https://github.com/misohena/el-easydraw

その一環として今日はカラーピッカーを作りました。この手のソフトには必ずあるアレです。

Emacs上での先行事例はいくつかあるようでしたがSVGでの実装は見当たりませんでしたし、まぁ、自分で作りたいじゃないですか。こういうの作るの楽しいですし。

というわけで出来たのがこちら。

https://github.com/misohena/el-easydraw/blob/master/edraw-color-picker.el

一応ライブラリとして他で使い回すことを考えています。

応用としてとりあえず作ったコマンドがいくつか。

edraw-color-picker-read-colorはread-colorの代わりを意識して作った色入力コマンドです。ミニバッファ内にカラーピッカーを配置してみました。文字からでもカラーピッカーからでも色を選択できます。

edraw-color-picker-insert-colorは選択した色をそのままバッファに挿入するコマンドです。またedraw-color-picker-replace-color-at-pointは現在のポイントの位置にある色表記を読み取ってカラーピッカーで選択した色に置き換えるコマンドです。これらはバッファ内にインラインでカラーピッカーが表示されます。

SVGは本当に簡単でこういう絵を出すのはサクッとすぐに出来ます。いや、本当は少し調査が必要だったのが二点。meshGradientの対応状況と色相バーの仕様です。こういう二次元のグラデーションで連想するのがメッシュ状の図形(いわゆるポリゴンの組み合わせ)で頂点に色を設定する仕組みです。3Dグラフィックスではおなじみですよね。SVGにも似たような仕組みがあったようなと調べてみたのですが、残念ながらEmacs(というかlibrsvg)では対応していないようですね(そもそもmeshGradient自体がSVG2から先送りされてたんですね)。幸い二枚のグラデーションを重ねれば良いとすぐに気がつけました。もう一点の色相バーですが、これ6色(赤、黄、緑、水、青、紫)を均等に並べて線形補間すればいいだけみたいですね。というわけでそれさえ分かればこういうカラーピッカーの絵自体はすぐに作れました。

画像内の各パーツは「領域」というオブジェクトで構成されています。指定に基づいて「領域」をレイアウト処理することで、いくらか柔軟に構成要素を増やしたり減らしたりできるようになっています。

領域にマウスイベントを配信(ディスパッチ)する仕組みを作り、それに反応して各部が動くようにしていきます。マウスイベントを受けて関連付けられた値が変わり、値の変更が通知されて表示が変わります。

各領域で選択した場所から最終的な色を求める方法ですが、色相バー(1次元)→彩度明度領域(2次元)→不透明度バー(1次元)の順に処理していきます。色相バーで選んだ色が彩度明度領域の右上の色になります。彩度明度領域は水平のグラデーション(左:白から右:色相選択色)の上に垂直グラデーション(上:透明黒から下:不透明黒)が重なっています。選んだ位置によって線形補間で水平、垂直の順で色を求めていきます。その色が今度は不透明度バーの上の色になって、最後に不透明度バーで選択した不透明度をその色に適用して完了です。仕組み自体はグラデーションの内容に依存していないので、色相、彩度、明度の軸を入れ替えても機能すると思いますし、1次元バーを緑、2次元領域を青と赤、などとしても大丈夫だと思います。(そのための切り替えUIを作るのが面倒くさかったのでやってませんが)

こうして出来たSVG画像はテキストプロパティまたはオーバーレイを使ってEmacs内に表示されます。というかEmacsではそれしか画像を表示する方法はありません(環境依存性の強い方法を除けば)。テキストプロパティでも良いのですが、オーバーレイの方がこういう用途では使いやすいでしょう。

オーバーレイにも画像を表示できる場所が三つあります。before-stringとdisplayとafter-stringです。displayはいいとして、before-stringとafter-stringですが、これはオーバーレイの前後に文字列を挿入するためのプロパティです。一見画像とは関係なさそうですが、この文字列にpropertize関数でdisplayテキストプロパティを適用するとオーバーレイの前後にさらに画像を表示することが可能になります。

これら色々ある表示方法を都合に合わせて選択できるように構造には柔軟性を持たせてあります。

先行事例を見てみると表示にフレームを使っているものがありました。普通のフレームを使っているものやchild frameという比較的最近のEmacsで使えるようになった仕組みを使っているものもありました。child frameを使うとフレーム内の好きな位置に重ねることが出来るのでポップアップで情報を出すパッケージで使われているようです。

とはいえフレームは扱いが難しく勉強が必要なので、とりあえずオーバーレイだけで出来る範囲で実装しています。

カラーピッカーはどこに表示すれば良いのでしょうか。だいたいポイント(やマウスカーソル)の近くですよね。ただ、ポイントの左や右にカラーピッカーのオーバーレイを挿入すると行が大きく膨らんで見づらくなってしまいますし、ウィンドウの左右からはみ出して見えなくなってしまうこともあります。となれば上の行か下の行に表示してはどうでしょう。上の行や下の行に適切な表示カラムが無いならどうすればいいでしょうか。幸いオーバーレイは行を新たに作ることが出来ます。before-string、display、after-stringの各プロパティにはそれぞれ文字列が指定できますが、いずれでも"\n"を入れることで改行が出来ます。例えば現在ポイントが20カラム目にあるとして、その真下付近に画像を表示するには、行末の改行文字にオーバーレイをかけて、before-stringを "\n " (←空白20個 - 画像の幅/2くらい)、displayに画像、after-stringに "\n" を指定してやればOKです。水平スクロールしている可能性があるのでwindow-hscrollの値を考慮するのを忘れずに。

また、ミニバッファに色を入力するようなシチュエーションでは画面の下の方にカラーピッカーを表示して欲しいです。いや、いっそのことミニバッファ内にカラーピッカーを入れたらどうでしょう。ここでもオーバーレイに改行させれば上をカラーピッカー、下を入力欄とすることが出来ます。ただし一つ注意点が。バッファの先頭にオーバーレイを入れたいわけですが、先頭の1文字にかけるとbefore-stringに画像を設定しなければならずその後に改行が入れられません。displayで改行すると1文字目が(改行に置き換わって)表示されなくなってしまいますし、after-stringで改行すると1文字目の後で改行されてしまいます。なので先頭の空の範囲((point-min)から(point-min)まで)にオーバーレイを設定します。注意点が二つ。evaporateプロパティがtだと空の範囲になった段階でオーバーレイが消えてしまいます。なのでevaporateは使わずちゃんとオーバーレイを管理する必要があります。もう一点は空の範囲のオーバーレイではdisplayプロパティが機能しないということ。before-stringとafter-stringは表示されるのですが、なぜかdisplayプロパティは空の範囲だと表示されません。なのでbefore-stringに画像を、after-stringに"\n"を指定することになります。(2021-09-07追記:よく考えたらbefore-stringの中で文字列の一部にだけdisplayプロパティをかけて、残りで改行すれば済むような気もします。未確認ですが、多分動くのではないかと)

他にもEmacsの色名とWeb(HTMLやCSS)の色名に対応するとか、色の表現形式とか、画像のスケーリングについてとか(上のスクリーンショット、ピッカーの大きさが違うのに気がつきましたか？)、色々書きたいことは山ほどありますが、この辺にしておきます。

(追記: Emacsのcss-modeやcustomize-face等でカラーピッカーを使う設定)

(2022-08-15追記:CompanyからCorfuへ移行しました)

Emacsのバッファ内での入力補完を行うcompany-modeですが、使っていると困ることも色々ありました。それで少し設定を変えて使っていたのですが、まだ不満が残っていたのでここらでゆっくり検討してみました。

一番困るのが誤入力を助長してしまうという点です。テキスト入力中に勝手に候補を出すまでは良いのですが、RETを押すと勝手に出してきた候補を選択してしまい不要な文字列を付け足してしまいます。

例えば 100 と入力して RET を押したら 100 の後に改行が入ることを期待するわけですが、改行を打つ直前に勝手に 100 で始まる文字列を候補に出してきて、それが入力されてしまうわけです。例えばバッファ内に他に 10000 と書いてある部分があると、 100 ではなく 10000 が入力されてしまうわけです。入力時に気がつけば良いのですが、気がつかずに後から計算結果が合わなくて発覚したこともありました。

;; case1
;; 自動起動を禁止する。(self-insert系を除外する)
(setq company-begin-commands
      '(c-scope-operator c-electric-colon c-electric-lt-gt c-electric-slash))

;; case2
;; dabbrevは手動で起動したときだけ有効にする。
;; アイドルタイムから始まった場合は、一時的に company-backends から
;; company-dabbrev を取り除く。
(defun my-company-idle-begin (oldfun &rest args)
  (let ((company-backends (remq 'company-dabbrev company-backends)))
    (apply oldfun args)))
(advice-add 'company-idle-begin :around 'my-company-idle-begin)

;; いくつかのモードで自動的に候補を出すのを禁止する。
;; プログラミング系のモードでは比較的大丈夫な場合が多い。
;; 文法上入力できるものが限られており、補完が正しい可能性が高いから。
(defun my-company-inhibit-idle-begin ()
  (setq-local company-begin-commands nil))
(add-hook 'org-mode-hook #'my-company-inhibit-idle-begin)
(add-hook 'text-mode-hook #'my-company-inhibit-idle-begin)

When `company-selection-default' is nil, add a special pseudo candidates
meant for no selection."

;; case3
;; 基本的に候補は無選択状態から始める。
;; 誤って確定してしまうのを防ぐ。
(setq-default company-selection-default nil)
(setq-default company-selection nil)

;; 手動起動したときには選択状態から始める。何か選びたいはずなので。
;; 自動起動したときでもモードによっては選択状態から始める。
;; 文法的に正しい候補が出せる可能性が高いとき。
(defun my-company-should-select-first-p ()
  (or
   company--manual-action ;;手動で起動したとき。
   (and (boundp 'lsp-mode) lsp-mode))) ;;LSPが使えるモードは補完の精度が高いはずなので。 (memq major-mode '(c-mode c++-mode))とかでも可。
(defun my-company-auto-begin (oldfun)
  (let ((company-selection-default
         (if (my-company-should-select-first-p) 0 nil)))
    (funcall oldfun)))
(advice-add 'company-auto-begin :around 'my-company-auto-begin)

;; 無選択状態の時にTABやRETが入力されたら
;; そのバッファのモード本来のTABやRETを実行する。
(defun my-company-complete-respecting-user-input (&rest args)
  "ユーザー入力を尊重した補完を行う。"
  (interactive)
  (if (null company-selection)
      ;; モード本来の割り当てを実行する。
      (progn
        (company-abort)
        (company--unread-this-command-keys))
    ;; companyの(リマップ元の)コマンドを実行する。
    (apply this-original-command args)))
(define-key company-active-map [remap company-complete-selection]
  ;;RETに割り当てられているコマンドをリマップ
  'my-company-complete-respecting-user-input)
(define-key company-active-map [remap company-complete-common]
  ;;TABに割り当てられているコマンドをリマップ
  'my-company-complete-respecting-user-input)

  (defun company--show-inline-p ()
    (and (not (cdr company-candidates))
+        (or company-selection-default (null company-candidates)) ;;追加
         company-common
         (not (eq t (compare-strings company-prefix nil nil
                                     (car company-candidates) nil nil
                                     t)))
         (or (eq (company-call-backend 'ignore-case) 'keep-prefix)
             (string-prefix-p company-prefix company-common))))

(defun my-company--show-inline-p (old-fun)
  (and
   ;; Include "no selection" as candidates
   (or company-selection-default (null company-candidates))
   (funcall old-fun)))
(advice-add 'company--show-inline-p :around 'my-company--show-inline-p)

(defun company-update-candidates (candidates)
  (setq company-candidates-length (length candidates))
  (if company-selection-changed
      ;; Try to restore the selection
      (let ((selected (and company-selection
                           (nth company-selection company-candidates))))
        (setq company-candidates candidates)
        (when selected
          (setq company-selection 0)
          (catch 'found
            (while candidates
              (let ((candidate (pop candidates)))
                (when (and (string= candidate selected)
                           (equal (company-call-backend 'annotation candidate)
                                  (company-call-backend 'annotation selected)))
                  (throw 'found t)))
              (cl-incf company-selection))
            ;; ★★★ここを直したい！★★★
            (setq company-selection company-selection-default
                  company-selection-changed nil))))
    (setq company-selection company-selection-default
          company-candidates candidates))
  ;; Calculate common.
  (let ((completion-ignore-case (company-call-backend 'ignore-case)))
    ;; We want to support non-prefix completion, so filtering is the
    ;; responsibility of each respective backend, not ours.
    ;; On the other hand, we don't want to replace non-prefix input in
    ;; `company-complete-common', unless there's only one candidate.
    (setq company-common
          (if (cdr company-candidates)
              (let ((common (try-completion "" company-candidates)))
                (when (string-prefix-p company-prefix common
                                       completion-ignore-case)
                  common))
            (car company-candidates)))))

(defun my-company-update-candidates (old-fun candidates)
  (let ((old-selection-changed company-selection-changed)
        (old-selection company-selection)
        ;; call the original function
        (result (funcall old-fun candidates)))
    ;; keep company-selection-changed
    (setq company-selection-changed old-selection-changed)
    ;; keep company-selection that is not nil
    (when (and old-selection (null company-selection) candidates)
      (setq company-selection 0))
    result))
(advice-add 'company-update-candidates :around 'my-company-update-candidates)

(set-face-background 'company-tooltip-selection "#a62")

Ivyでは ivy-use-virtual-buffers を t にすると ivy-switch-buffer (C-x b) で(recentfや)ブックマーク内のファイルが選べるようになりますが、候補として登録されるのはあくまでファイル名(ivy-virtual-abbreviate を設定するとディレクトリパスも含めることは出来る)だけでブックマーク名は登録されません。なのでいくら分かりやすいブックマーク名を付けていても ivy-switch-buffer でそれを元にファイルを検索することは出来ません。なのでそれを出来るようにしてみました。

(require 'ivy)

(defun my-ivy-bookmark-name-filename-list ()
  "Return bookmark (name . filename) list as virtual buffer format."
  (delq nil
        (mapcar (lambda (record)
                  (when record
                    (let ((name (bookmark-name-from-full-record record))
                          (filename (bookmark-get-filename record)))
                      (when (and name filename)
                        (cons
                         (propertize
                          (format "*bookmark:%s" name)
                          'face 'ivy-virtual)
                         filename)))))
                bookmark-alist)))

(defun my-ivy-bookmark-append-advice (orig-fun)
  (let ((result-orig (funcall orig-fun))
        (my-virtual-list (my-ivy-bookmark-name-filename-list)))
    (setq ivy--virtual-buffers (append ivy--virtual-buffers my-virtual-list))
    (append result-orig (mapcar #'car my-virtual-list))))

(advice-add 'ivy--virtual-buffers :around 'my-ivy-bookmark-append-advice)
;;(advice-remove 'ivy--virtual-buffers 'my-ivy-bookmark-append-advice)

ivy-switch-buffer が扱うのはあくまでバッファ名です。現実にあるバッファの名前を選んでそこへ切り替えます。なのでrecentfやブックマークのファイル名はバッファ名ではないので「仮想バッファ」の名前として扱うことで無理矢理処理しています。仮想バッファ名リストを生成する関数が ivy--virtual-buffers です。その関数は、 ivy--virtual-buffers という変数(関数と同じ名前でややこしいですが)に仮想バッファ名とファイル名の対応表を構築した上で仮想バッファ名のリストを返します。

なので ivy--virtual-buffers 関数にadviceをかけて仮想バッファを付け足すのが上のコードです。

ivy-switch-bufferで選べる候補が気に入らないという方はこのようなやり方で候補を追加してみてはいかがでしょうか。

ちなみに、 *scratch* が無くても常に *scratch* を選べるようにするには my-ivy-bookmark-append-advice が返すリストに一つ付け加えるだけです。

(defun my-ivy-bookmark-append-advice (orig-fun)
  (let ((result-orig (funcall orig-fun))
        (my-virtual-list (my-ivy-bookmark-name-filename-list)))
    (setq ivy--virtual-buffers (append ivy--virtual-buffers my-virtual-list))
    (append result-orig (mapcar #'car my-virtual-list) '("*scratch*"))))

こうしておくと、もし知らないうちに *scratch* を閉じてしまっていても *scratch* というバッファ名を選べて新しくバッファを作成することが出来ます。

以前flycheckを試したときにNULというファイルが出来て消すのが大変だったのでflymakeでいいやーと思ったことがあったのですが、最近また調べたところ対処法を書いているサイトを見つけました。

Emacs Flycheck

下記の記述だと、Windowsで、gcc によっては、同じディレクトリに "NUL" というファイルが生成されることがある。

:command ("gcc" "-c" "-I../../inc" "-I." "-O1" "-Wall" source "-o" null-device)

その場合、下記のように temporary-file-name を指定すると回避できる

:command ("gcc" "-c" "-I../../inc" "-I." "-O1" "-Wall" source "-o" temporary-file-name)

checker定義内の 'null-device は同名の変数null-deviceの値で置き換えられて、Windowsだと "NUL" になります。これをCygwinやMSYS2/MinGWのgccが受け取るとコンパイルが成功したときにそのままNULというファイルを出力してしまうのが原因のようです。

同じようにcheckerを再定義すれば良いのかなと思ったのですが、flycheck.elを見てみると沢山のcheckerが定義されていてその中でnull-deviceも沢山使われていました。

そもそもcheckerを再定義するのも面倒ですし、かといってnull-deviceの値を書き替えるのも(他にどこで使われているのか分からないので)怖いですし、手っ取り早くadviceでnull-deviceをtemporary-file-nameに置き換えてしまうことにしました。

;;; Windowsでnull-deviceを使わないようにする。
;; null-deviceはNULなので、CygwinやMinGWだとNULというファイルを作ってしまう。
;; flycheck-command-wrapper-function でNULを置き換えても良いのだが
;; flycheck-substitute-argument でやった方が確実だし簡単。
(when (locate-library "flycheck")
  (with-eval-after-load 'flycheck
    (defun my-flycheck-substitute-argument (old-func arg checker &optional rest)
      (when (eq arg 'null-device)
        (setq arg 'temporary-file-name))

      (apply old-func arg checker rest))
    (advice-add 'flycheck-substitute-argument :around 'my-flycheck-substitute-argument)))

最近はLSPの方でエラー箇所を検出してしまうので必要ないのかもしれませんけどまたNULファイルが出来ると面倒なので念のため。