My custom helm completion for projectile

fmc-helm-projectile-completion-fn.el

(require 'dash)
(require 's)
(require 'f)


(defface fmc/completion-label-face  '((t (:weight bold :height 1.1)))
  "Label face")

(defface fmc/completion-delimiter-face '((t (:weight light :height 0.9)))
  "Delimiter face")

(defface fmc/completion-description-face '((t (:weight extra-light :height 0.9)))
  "Description face")


(defvar fmc/completion-label-face 'fmc/completion-label-face
  "Label face var")

(defvar fmc/completion-delimiter-face 'fmc/completion-delimiter-face
  "Delimiter face var")

(defvar fmc/completion-description-face 'fmc/completion-description-face
  "Description face var")


(defconst fmc/reverse-notation-separator ".."
  "My reversed separator")

(defconst fmc/completion-separator ">>"
  "My completion separator")

(defun fmc/uniquify-project-paths (project-paths)
  "Customize how projectile files and more are displayed by PROJECT-PATHS"
  (lexical-let*
      ((fn-notation
        (lambda (path)
          (lexical-let ((fn-pieces (f-split path)))
            (string-join (reverse fn-pieces) fmc/reverse-notation-separator))))
       (relative-parent-path
        (lambda (path relative-path)
          (lexical-let
              ((split-path (f-split path))
               (split-relative-path (f-split relative-path)))
            (string-join
             (-drop-last (length split-relative-path) split-path)
             (f-path-separator)))))

       (as-pair
        (lambda (ish)
          (if (listp ish)
              ish (cons ish ish))))
       (map-car
        (lambda (f pair)
          (cons (funcall f (car pair))
             (cdr pair))))
       (pair-as-label
        (lambda (pairs)
          (lexical-let*
              ((display-formatter
                (lambda (name description)
                  (format "%-s %s %-s"
                          (propertize name 'font-lock-face 'fmc/completion-label-face)
                          (propertize fmc/completion-separator 'font-lock-face 'fmc/completion-separator)
                          (propertize description 'font-lock-face 'fmc/completion-description-face)))))
            (lambda (pair)
              (lexical-let*
                  ((unique-path (car pair))
                   (full-path (cdr pair))
                   (parent-path
                    (funcall relative-parent-path
                       full-path
                       unique-path))

                   (display-name
                    (funcall fn-notation unique-path))
                   (display-description
                    (funcall fn-notation parent-path))

                   (display-label
                    (funcall display-formatter
                       display-name
                       display-description)))
                (cons display-label (cdr pair)))))))
       (uniquify-paths
        (lambda (paths)
          ;; Ideally, this is just f-uniquify-alist but there is a minor contrivance
          (lexical-let*
              ((is-dir
                (lambda (path)
                  (string-equal (f-path-separator)
                                (s-right 1 path))))

               (swap-pair (lambda (pair)
                            (cons (cdr pair) (car pair))))
               (map-pair
                (lambda (f pair)
                  (cons (funcall f  (car pair)) (funcall f (cdr pair)))))

               (remove-last-separator
                (lambda (text)
                  (s-left (1- (length text)) text)))
               (add-separator
                (lambda (text)
                  (concat text (f-path-separator)))))
            (mapcar (-compose
                     swap-pair)
                    (if (-any is-dir paths)
                        ;; Remove separator, uniquify and add separator back
                        ;; Weird performance shiznit
                        (funcall
                         (-compose
                          (-partial #'mapcar (-partial map-pair add-separator))
                          #'f-uniquify-alist
                          (-partial #'mapcar remove-last-separator))
                         paths)
                      (f-uniquify-alist paths))))))
       (refined-paths  (funcall uniquify-paths project-paths)))
    (mapcar (-compose
             (funcall pair-as-label refined-paths)
             as-pair)
            refined-paths)))


(require 'helm)

(defun fmc/custom-helm-completion (prompt choices)
  "This custom projectile completion with helm does two things:
first it reverses the file path to emphasize the file name,
secondly it uniquifies the paths via `f-uniquify-alist',
optionally some extra coloring.

   I would like to use `completing-read' but it does not handle
propertized alist well. You can remove the `propertize' from `display-formatter'
but that is a deal breaker for me."
  (helm-comp-read prompt
                  (fmc/uniquify-project-paths choices)
                  :must-match t))

(setq projectile-completion-system #'fmc/custom-helm-completion)

Screenshot