(require 'tabulated-list)

(defvar-local font-family-menu-test-string nil
  "Test string to display in the menu.")

(defvar font-family-menu-mode-map
  (let ((map (make-sparse-keymap))
        (menu-map (make-sparse-keymap "Font Family")))
    (set-keymap-parent map tabulated-list-mode-map)
    (define-key map "\C-m" 'font-family-menu-set-frame-font)
    (define-key map "x" 'font-family-menu-set-test-string)
    map)
  "Local keymap for `font-family-menu-mode' buffers.")

(define-derived-mode font-family-menu-mode tabulated-list-mode "Font Family Menu"
  "Inspect font families and pick a frame font.
Display the name of the font family in that family.  Use
`font-family-set-test-string' to set a test string.

 \\<font-family-menu-mode-map> \\{font-family-menu-mode-map}"
  (setq tabulated-list-format
        `[("Font Family" 30 t)
          ("Text" 30 nil)])
  (setq tabulated-list-padding 2)
  (setq tabulated-list-sort-key (cons "Font Family" nil))
  (setq tabulated-list-use-header-line nil)
  (setq header-line-format "Font families")
  (add-hook 'tabulated-list-revert-hook 'font-family-menu--refresh nil t)
  (font-family-menu--refresh)
  (tabulated-list-init-header)
  (tabulated-list-print))

(defun list-font-families ()
  "Display the name of the font family using it's own face.
Use `font-family-menu-set-test-string' to display a test string
instead."
  (interactive)
  (let ((buf (get-buffer-create "*Font Families*")))
    (with-current-buffer buf
      (font-family-menu-mode))
    (switch-to-buffer buf)))

(defun font-family-menu--refresh ()
  "Re-populate `tabulated-list-entries'."
  (let ((f (delete-dups (font-family-list))))
    (setq tabulated-list-entries
	  (mapcar
	   (lambda (f)
	     (let ((s (or font-family-menu-test-string f)))
	       (list f (vector
			(cons f `(font-family ,f action font-family-menu-set-frame-font))
			(propertize s 'face (list :family f))))))
	   f))))

(defun font-family-menu-set-frame-font ()
  "Set the frame font to current one."
  (interactive)
  (when (derived-mode-p 'font-family-menu-mode)
      (let ((f (tabulated-list-get-id)))
	(when (and f (yes-or-no-p (concat "Set frame font to " f)))
	  (set-frame-font f nil t)))))

(defun font-family-menu-set-test-string (s)
  "Set the test string."
  (interactive "sDisplay string: ")
  (when (derived-mode-p 'font-family-menu-mode)
    (if (and (stringp s) (not (string= s "")))
	(setq font-family-menu-test-string s)
      (setq font-family-menu-test-string nil))
        (font-family-menu--refresh)
	(tabulated-list-print)))

(provide 'font-family)