Webカラーwidgetを作る(Emacs Widget Libraryについて調べる2)

(define-widget 'color 'editable-field
  "Choose a color name (with sample)."
  :format "%{%t%}: %v (%{sample%})\n"
  :value-create 'widget-color-value-create
  :size (1+ (apply #'max 13 ; Longest RGB hex string.
                   (mapcar #'length (defined-colors))))
  :tag "Color"
  :value "black"
  :completions (defined-colors)
  :sample-face-get 'widget-color-sample-face-get
  :notify 'widget-color-notify
  :match #'widget-color-match
  :validate #'widget-color-validate
  :action 'widget-color-action)

;; 実装にはedraw-color.elやedraw-color-picker.elの助けを借ります。
;; https://github.com/misohena/el-easydraw/blob/master/edraw-color.el
;; https://github.com/misohena/el-easydraw/blob/master/edraw-color-picker.el
(require 'edraw-color)
(require 'edraw-color-picker)

(define-widget 'my-web-color 'editable-field
  "Choose a web color (with sample)."
  :value "black"
  ;; タグ: 値 サンプル
  :format "%{%t%}: %v %{      %}\n"
  ;; デフォルトのタグ(%t部分)
  :tag "Color"
  ;; 値部分の作成(%v部分)
  :value-create 'my-widget-web-color-value-create
  :size 26 ;; rgba(255,255,255,1.2345)くらいが収まる長さにしておく
  ;; 補完候補(C-M-i (M-TAB)で補完候補を出せる)
  :completions (mapcar #'car edraw-color-web-keywords)
  ;; 見本部分のface
  :sample-face-get 'my-widget-web-color-sample-face-get
  ;; 見本の更新
  :notify 'my-widget-web-color-notify
  ;; 値の検証
  :match #'my-widget-web-color-match
  :validate #'my-widget-web-color-validate
  ;; ミニバッファからの入力
  :action 'my-widget-web-color-action)

(defun my-widget-web-color-value-create (widget)
  ;; 値を表す部分(:formatの%v部分)をバッファ上に作成します。

  ;; editable-fieldとしての部分を作成。
  (widget-field-value-create widget)
  (widget-insert " ")
  ;; その後にChooseボタンを追加。
  (widget-create-child-and-convert
   widget 'push-button
   :tag " Choose " :action 'my-widget-web-color--choose-action)
  (widget-insert " "))

(defun my-widget-web-color--choose-action (widget &optional _event)
  ;; Chooseボタンが押されたら呼び出されます。
  ;; カラーピッカーで色を入力してもらい、それを親widgetの値として設定します。
  (let* ((wp (widget-get widget :parent))
         (old-color (widget-value wp))
         (new-color (edraw-color-picker-read-color nil old-color)))
    (widget-value-set wp new-color)))

(defun my-widget-web-color-sample-face-get (widget)
  ;; 見本部分(:formatの%{から%}までの間)に適用するfaceを返します。
  (let ((color (condition-case nil
                   (edraw-color-from-string (widget-value widget))
                 (error (widget-get widget :value)))))
    (if color
        (list (cons 'background-color (edraw-to-string-hex (edraw-change-a color 1.0)))) ;; 半透明が表現できないので無理矢理不透明にします。本当はSVGで市松模様背景付きのサンプルを作りたい所。
      'default)))

(defun my-widget-web-color-action (widget &optional event)
  "Prompt for a color."
  ;; フィールド上でRETを押したときに呼び出されます。
  ;; ミニバッファから色を入力してもらい、それをwidgetの値として設定します。
  (let* ((old-color (widget-value widget))
         (new-color (edraw-color-picker-read-color nil old-color)))
    (when new-color
      (widget-value-set widget new-color)
      (widget-setup)
      (widget-apply widget :notify widget event))))

(defun my-widget-web-color-notify (widget child &optional event)
  "Update the sample, and notify the parent."
  ;; 何かイベントが発生したときに呼び出されます。
  ;; たいていの場合テキストが変化したときなので、サンプルのfaceを更新します。
  (overlay-put (widget-get widget :sample-overlay)
               'face (widget-apply widget :sample-face-get))
  (widget-default-notify widget child event))

(defun my-widget-web-color-match (_widget value)
  ;; WIDGETにVALUEを設定可能なら非nilを返します。
  (and (stringp value)
       (or (assoc value edraw-color-web-keywords)
           (string-match edraw-color-string-patterns-re value))))

(defun my-widget-web-color-validate (widget)
  ;; WIDGETの現在の値が正当かチェックします。
  ;; エラーがなければnilを返します。
  (let ((value (widget-value widget)))
    (unless (my-widget-web-color-match widget value)
      (widget-put widget :error (format "Invalid color: %S" value))
      widget)))

(pop-to-buffer (generate-new-buffer "*Widget Example*"))
(widget-insert "\n")
(widget-create 'my-web-color
               :tag "色"
               "black")
(use-local-map widget-keymap)
(widget-setup)

(defcustom my-hogehoge-color "#ff0000"
  "My Hogehoge HTML color."
  :type 'my-web-color)

(defun my-hogehoge-html ()
  (format "<span style=\"color: %s\">hogehoge</span>" my-hogehoge-color))