Emacs dual header line

dual-header.el

;; Dual header line is possible by exploiting the tab-bar line that
;; sits on top of the header line and is generally hidden. For the
;; icon, it has to be precisely cut in top and bottom part and each
;; part is concatenated with either the tab-line or header-line.

(defun dual-header (top bottom)
  "This installs a double line header in current buffer using both tab line (TOP) and header line (BOTTOM)."

  (set-face-attribute 'tab-line (selected-frame)
                      :foreground (face-foreground 'default)
                      :background (face-background 'highlight)
                      :underline nil
                      :overline (face-foreground 'default)
                      :box nil
                      :height (face-attribute 'default :height))

  (set-face-attribute 'header-line (selected-frame)
                      :foreground (face-foreground 'default)
                      :background (face-background 'highlight)
                      :underline (face-foreground 'default)
                      :overline nil
                      :box nil
                      :height (face-attribute 'default :height))
  (setq tab-line-format
        (concat (propertize " " 'display '(space :width (1))
                                'face `(:background ,(face-foreground 'default)))
                top
                (propertize " " 'display '(raise +0.25))
                (propertize " " 'display '(space :align-to (- right (1))))
                (propertize " " 'display '(space :width (1))
                                'face `(:background ,(face-foreground 'default)))))

  (setq header-line-format
        (concat (propertize " " 'display '(space :width (1))
                                'face `(:background ,(face-foreground 'default)))
                bottom
                (propertize " " 'display '(raise -0.25)
                                'face `( :underline (:color "black" :position 0)))
                (propertize " " 'display '(space :align-to (- right (1))))
                (propertize " " 'display '(space :width (1))
                                'face `(:background ,(face-foreground 'default))))))


(defun dual-header-image (data)
  "This makes the image DATA to fit exacly two lines height and makes it
square in the process."

  (let* ((image (cond ((file-regular-p data)
                       (create-image data))
                      ((imagep data)
                       data)
                      (t (let ((collection (nth 0 (split-string data "/")))
                               (name (nth 1 (split-string data "/"))))
                           (svg-lib-icon name nil :collection collection
                                         :stroke 0 :scale 1.0 :padding 0)))))
         (img-width (car (image-size image t)))
         (img-height (cdr (image-size image t)))
         (ch (frame-char-height))
         (cw (frame-char-width))
         (icon-height (* 2 ch))
         (char-width  (+ 1 (truncate (/ (* 2 ch) cw))))
         (icon-width  (* char-width cw))
         (scale (/ (float icon-height) (float img-height)))
         (scaled-width (truncate (* scale img-width)))
         (scaled-height (truncate (* scale img-height)))
         (icon-true-width (truncate (* img-width scale)))
         (margin (max 0 (- icon-width icon-true-width)))
         (icon-width (+ icon-width (% margin 2)))
         (margin (- margin (% margin 2)))
         (thumbnail (cons (car image) (cl-copy-list (cdr image)))))
    (plist-put (cdr thumbnail) :height scaled-height)
    (plist-put (cdr thumbnail) :width  scaled-width)
    (plist-put (cdr thumbnail) :margin (cons (/ margin 2) 0))
    (plist-put (cdr thumbnail) :ascent 80)
    thumbnail))

(defun dual-header-split-image (image)
  "This splits IMAGE into top and bottom parts."

  (let* ((image-width (car (image-size image t)))
         (image-height (cdr (image-size image t)))
         (char-height (frame-char-height))
         (char-width (frame-char-width))
         (text-width (/ image-width char-width)))
    (cons
     (propertize (make-string text-width ? )
                 'display (list (list 'slice 0  0 image-width char-height)
                                 image)
                 'line-height t)
     (propertize (make-string text-width ? )
                 'display (list (list 'slice 0  char-height image-width char-height)
                                 image :ascent 0)
                 'line-height t))))


(let ((icon (dual-header-split-image
             (dual-header-image
              "~/Documents/Emacs/emacs-square.svg"))))
  (dual-header
   (concat (propertize " " 'display '(space :width (4)))
           (car icon)
           " "
           (propertize (format-mode-line "%b") 'face 'bold))
   (concat (propertize " " 'display '(space :width (4)))
           (cdr icon)
           " "
           (format-mode-line "(lisp mode)"))))

emacs-square.svg