(require 'seq)
(require 'pcase)

(defsubst biblio--as-list (x)
  "Make X a list, if it isn't."
  (if (consp x) x (list x)))

(defun biblio--map-keymap (func map)
  "Call `map-keymap' on FUNC and MAP, and collect the results."
  (let ((out))
    (map-keymap (lambda (&rest args) (push (apply func args) out)) map)
    (nreverse out)))

(defun biblio--flatten-map (keymap &optional prefix)
  "Flatten KEYMAP, prefixing its keys with PREFIX.
This should really be in Emacs core (in Elisp), instead of being
implemented in C (at least for sparse keymaps).  Don't run this on
non-sparse keymaps."
  (nreverse
   (cond
    ((keymapp keymap)
     (seq-map (lambda (key-value)
                "Add PREFIX to key in KEY-VALUE."
                (cons (append prefix (biblio--as-list (car key-value)))
                      (cdr key-value)))
              (delq nil
                    (apply
                     #'seq-concatenate
                     'list (biblio--map-keymap
                            (lambda (k v)
                              "Return a list of bindings in V, prefixed by K."
                              (biblio--flatten-map v (biblio--as-list k)))
                            keymap)))))
    ;; FIXME This breaks if keymap is a symbol whose function cell is a keymap
    ((symbolp keymap)
     (list (cons prefix keymap))))))

(defun biblio--group-alist (alist)
  "Return a copy of ALIST whose keys are lists of keys, grouped by value.
That is, if two key map to `eq' values, they are grouped."
  (let ((map (make-hash-table :test 'eq))
        (new-alist nil))
    (pcase-dolist (`(,key . ,value) alist)
      (puthash value (cons key (gethash value map)) map))
    (pcase-dolist (`(,_ . ,value) alist)
      (let ((keys (gethash value map)))
        (when keys
          (push (cons (nreverse keys) value) new-alist)
          (puthash value nil map))))
    (nreverse new-alist)))

(defun biblio--quote (str)
  "Quote STR and call `substitute-command-keys' on it."
  (if str (substitute-command-keys (concat "`" str "'")) ""))

(defun biblio--quote-keys (keys)
  "Quote and concatenate keybindings in KEYS."
  (mapconcat (lambda (keyseq)
               (let ((key (ignore-errors (help-key-description keyseq nil))))
                 (if (and nil key (string-match-p " " key))
                     (biblio--quote key)
                   key)))
             keys ", "))

(defun biblio--brief-docs (command)
  "Return first line of documentation of COMMAND."
  (let ((docs (or (ignore-errors (documentation command t)) "")))
    (string-match "\\(.*\\)$" docs)
    (match-string-no-properties 1 docs)))

(defun biblio--help-with-major-mode-1 (keyseqs-command)
  "Print help on KEYSEQS-COMMAND to standard output."
  ;; (biblio-with-fontification 'font-lock-function-name-face
  (insert (biblio--quote-keys (car keyseqs-command)) " ")
  (insert (propertize "\t" 'display '(space :align-to 10)))
  ;; (insert "(")
  (insert-text-button (format "%S" (cdr keyseqs-command)))
  ;; (insert ")")
  (insert "\n")
  (insert (propertize (format "  %s\n" (biblio--brief-docs (cdr keyseqs-command)))
                      'face '(font-lock-comment-face (:height 0.95))))
  (insert (propertize "\n" 'face '(:height 0.3))))

(defun help-with-keymap (map &optional buf title)
  "Display help for keymap MAP in buffer BUF, with a given TITLE."
  (setq buf (or buf "*Keymap help*"))
  (with-help-window buf
    (when title (princ title))
    (let ((bindings (nreverse (biblio--group-alist (biblio--flatten-map map)))))
      (with-current-buffer buf
        (seq-do #'biblio--help-with-major-mode-1 bindings)))))

(defun help-with-major-mode ()
  "Display help for current major mode."
  (interactive)
  (help-with-keymap
   (current-local-map)
   (format "*%S help*" major-mode)
   (format "Help with %s\n\n" (biblio--quote (symbol-name major-mode)))))