Custom Emacs Lisp loader

xristos-loader.el

;;; xristos-loader.el --- Custom loader -*- lexical-binding: t -*-

;;; TODO:
;;
;; Split `xristos/log' into its own library and add support for timestamps,
;; log entry collapse/expand with additional metadata and (maybe)
;; cross-references.

;;; Code:

(require 'cl-lib)

(defvar xristos/log-buffer-name "*xristos-log*")

(defvar xristos/log-faces-or-colors
  '((:info  . "#aadddd")
    (:error . "#ff3333")
    (:warn  . "#aaffaa")))

(defvar xristos/loader-features '())

(defun xristos/message (message &optional minibuffer)
  "Log message to `xristos/log-buffer-name' and optionally the minibuffer.

All text properties should be preserved (unlike 'message')."
  (when minibuffer
    (let ((message-log-max nil))
      (message message)))
  (with-current-buffer (get-buffer-create xristos/log-buffer-name)
    (goto-char (point-max))
    (let ((inhibit-read-only t))
      (unless (zerop (current-column)) (insert "\n"))
      (insert message)
      (insert "\n"))))

(defun xristos/log (level format-string &rest args)
  "Log message to `xristos/log-buffer-name'.

All text properties should be preserved (unlike 'message')."
  (cl-assert (member level '(:info :error :warn)))
  (let* ((face-or-color (cdr (assoc level xristos/log-faces-or-colors)))
         (message (propertize (format "%s" (apply 'format format-string args))
                              'face
                              (if (facep face-or-color)
                                  face-or-color
                                `(:foreground ,face-or-color)))))
    (xristos/message message)))

(defun xristos/feature-location (feature)
  "Return filesystem path that FEATURE was loaded from.

Return NIL if not found."
  (when (member feature features)
    (cl-loop for loaded-feature in load-history
             for path = (cl-first loaded-feature)
             when (cl-find `(provide . ,feature) loaded-feature :test 'equal)
             return path)))


(defun xristos/advice-require (f feature &optional filename noerror)
  "Require FEATURE whilst tracing all subsequent `require' calls.
Log everything through `xristos/log'.

Tracer will log library paths and elapsed time for each `require'.
Another implementation could use a dynamically-scoped function binding."
  (if (member feature features)
      ;; Library is already loaded
      (funcall f feature filename noerror)
    (let* ((start-time (current-time))
           (xristos/loader-features (cons feature xristos/loader-features))
           (state (mapconcat 'symbol-name (reverse xristos/loader-features) ":")))
      (xristos/log :info ":%s:" state)
      (condition-case err
          (funcall f feature filename noerror)
        (error
         (xristos/log :error ":%s:%s" state (error-message-string err))
         (signal (car err) (cdr err))))
      (xristos/log :info ":%s:loaded in %.3fs from %s"
                   state
                   (float-time (time-subtract (current-time) start-time))
                   ;; Needs to be called after target has been loaded
                   (xristos/feature-location feature)))))

(advice-add 'require :around #'xristos/advice-require)

(provide 'xristos-loader)
;;; xristos-loader.el ends here