;;; fmt.el --- Macro-based string interpolation library  -*- lexical-binding: t; -*-

;; Copyright (C) 2016  Clément Pit-Claudel

;; Author: Clément Pit-Claudel <address@hidden>
;; Keywords: convenience, extensions

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;

;;; Code:
(defconst fmt--sigil ?$)

;;; Printing utilities

(defun fmt--print (e &optional printer format-sequence)
  "Print E with PRINTER according to optional FORMAT-SEQUENCE.
With no FORMAT-SEQUENCE, use princ.  With no PRINTER, use FORMAT."
  (let ((print-quoted t)
        (print-length nil)
        (print-level nil))
    (if format-sequence
        (funcall (or printer 'format) format-sequence e)
      (prin1-to-string e t))))

;;; Specialized printers

(defun fmt--printers-str (_format-string v)
  "Format V as a string, but return \"\" if V is nil."
  (if v (format "%s" v) ""))

(defun fmt--printers-whereis (_format-string function)
  "Show a keybinding for FUNCTION."
  (substitute-command-keys (concat "\\[" (symbol-name function) "]")))

(defvar fmt--printers-alist '(("str" . fmt--printers-str)
                           ("date" . format-time-string)
                           ("where-is" . fmt--printers-whereis))
  "An alist mapping printer names to formatting functions.
Each formatting function should take a value and a format
sequence, and return a string.")

(defun fmt--get-printer (name)
  "Find printer for NAME."
  (or (cdr (assoc name fmt--printers-alist))
      (error "Unrecognized printer: %S" name)))

;;; Compiling format strings

(defun fmt--read-delimited ()
  "Read a string enclosed in a pair of delimiters."
  (let ((start (point)))
    (forward-list)
    (buffer-substring-no-properties (1+ start) (1- (point)))))

(defun fmt--read-format-sequence ()
  "Read a []-delimited format sequence, such as `[.2f]'."
  (when (eq (char-after) ?\[)
    (let ((str (fmt--read-delimited)))
      (if (string-match-p "^%" str)
          (list ''format str)
        (let* ((parts (split-string str "|")))
          (list (list 'quote (fmt--get-printer (car parts)))
                (mapconcat #'identity (cdr parts) "|")))))))

(defun fmt--read-braces ()
  "Read a {}-delimited form, such as `{12}'."
  (pcase-let* ((start (point))
               (expr (fmt--read-delimited))
               (`(,obj . ,count) (read-from-string expr)))
    (prog1 obj
      (unless (= count (length expr))
        (error "Expecting \"}\", but got %S instead"
               (buffer-substring (+ start count 1) (point-max)))))))

(defun fmt--read-var-name ()
  "Read an alphanumeric+dashes variable name, such as `ab0-cd'."
  (let ((start (point)))
    (if (> (skip-chars-forward "-[:alnum:]") 0)
        (intern (buffer-substring-no-properties start (point)))
      (error "Invalid fmt string when reaching %S"
             (buffer-substring (point) (point-max))))))

(defun fmt--read ()
  "Read one form, a lone sigil, or a variable, plus an optional format.
Returns a list (FORM PRINTER FORMAT-SEQUENCE)."
  (let* ((format-sequence (fmt--read-format-sequence))
         (next-char (char-after)))
    (apply #'list
           (cond
            ((equal next-char ?\() (read (current-buffer)))
            ((equal next-char ?\{) (fmt--read-braces))
            ((equal next-char fmt--sigil) (forward-char) (char-to-string fmt--sigil))
            (t (fmt--read-var-name)))
           format-sequence)))

(defun fmt--compile (expr)
  "Parse and compile a format expression EXPR."
  (with-temp-buffer
    (insert expr)
    (goto-char (point-min))
    (let ((chunks nil)
          (str-start (point))
          (sigil-str (char-to-string fmt--sigil)))
      (while (search-forward sigil-str nil t)
        (let ((str (buffer-substring-no-properties str-start (1- (point)))))
          (push str chunks)
          (push `(fmt--print ,@(fmt--read)) chunks)
          (setq str-start (point))))
      (push (buffer-substring-no-properties str-start (point-max)) chunks)
      (nreverse (seq-remove (lambda (x) (equal x "")) chunks)))))

;;; Public API

(defun fmt--1 (expr)
  "Compile a format expressions EXPR."
  (unless (stringp expr)
    (error "`fmt' requires a constant string"))
  (fmt--compile expr))

(defmacro fmt (&rest exprs)
  "Compile a sequence of format expressions EXPRS."
  (cons 'concat (apply #'append (mapcar #'fmt--1 exprs))))

(defmacro fmt-message (exprs)
  "Display one or more messages EXPRS.
EXPRS is compiled as a format expression."
  `(message "%s" (fmt ,@exprs)))

(provide 'fmt)
;;; fmt.el ends here