;;; byte-code-cache.el --- Compile files as they're used

;; Author:     Daniel Colascione <dan.colascione@gmail...>
;; Maintainer: Daniel Colascione <dan.colascione@gmail...>
;; Time-stamp: "2009-06-15 23:17:06 leycec"
;; Created: 16 Nov 2007
;; Version: 0.0.2
;; URL: http://hippie.raiazome.com
;; Keywords: abbrev,c,convenience,data,emulations,faces,files,lisp,matching,tools

;; This file is not part of GNU Emacs.

;;; License:
;; The information below applies to everything in this distribution,
;; except where noted.
;; 
;; Copyleft  2009 by Cecil Curry <http://www.raiazome.com>.
;; Copyright 2007 by Daniel Colascione <dan.colascione@gmail...>.
;; 
;; 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 L<http://www.gnu.org/licenses/>.

;;; Commentary:
;; Automatically cache byte-compiled versions of .el files as they're
;; loaded, automatically recompiling them as necessary.

;;; Installation:
;; Load this file as early as possible in ~/.emacs (after setting
;; variables, and after custom, if you used custom to set them.)
;; Anything loaded after it will be automatically byte-compiled.
;;
;; This file cannot byte-compile itself, so you should do that
;; separately.

;;; Change Log:
;; 2009-05-01  Cecil Curry  <http://raiazome.com/Cecil_Curry>
;;   * Added `bytecomp' as a hard dependency at the top-level. This
;;     feature is used throughout and, when not required at the top-
;;     level, produces errors when `byte-code-cache' itself is required.
;;   * Corrected platform dependency in `bcc-cache-directory'. This
;;     variable's default value should now behave properly under
;;     Microsoft Windows, as well as non-standard Emacs installations.
;;   * Corrected platform dependency in `bcc-cache-file-name'. This
;;     function, and feature, should now behave properly under
;;     Microsoft Windows.
;;   * Defined a new `bcc-cache-directory-name-to-file-name' function.
;;     This function abstracts out the above platform independency.
;;   * Defined a new `bcc-make-cached-file' function. This function
;;     abstracts out the compilation and caching of files from the
;;     `bcc-load-source-file' function. External code may call this
;;     function to manually update the bytecode cache for some or
;;     several files.
;;   * Removed the `bcc-delete-file-noerror' function. This function
;;     was only called from the `bcc-regenerate-cache' function, and
;;     performs a trivial task; as such, its implementation is moved
;;     into the latter function.
;;   * Removed reference to dynamically scoped variables in
;;     `bcc-regenerate-cache'. This function is now calleable as a
;;     standalone function as its documentation originally implied.
;;   * Renamed several existing internal functions, including
;;     `bcc-in-blacklist' to `bcc-string-match-list' and
;;     `bcc-unconditionally-kill-buffer' to
;;     `bcc-kill-buffer-unconditionally'.
;;   * Made function arguments `noerror' and `nomessage' optional
;;     where defined.
;;   * Renamed most other function arguments for clarity.
;;   * Removed extraneous whitespace from all functions.
;;   * Revised docstring documentation for most definitions.
;;   * Added a few new "FIXME:" comments, throughout.
;;   * Relicensed under version 3 of the GNU General Public License.
;;
;; 2007-11-16  Daniel Colascione <dan.colascione@gmail...>
;;   * Made more robust against pathological recursive invocations.

;;; Code:
;; Require `advice' for the documentation advice, below.
(require 'advice)

;; Require `bytecomp' explicitly instead of letting the call to
;; `byte-compile-file' automatically autoload it. We need its
;; `byte-compile-dest-file' function to be defined; if we define it
;; ourselves and then let `bytecomp' autoload, it will see that
;; `byte-compile-dest-file' is alreay defined and not define its version.
(require 'bytecomp)

;;; Customizations:
(defgroup byte-code-cache nil
  "Instead of separately byte-compiling everything, this package
intercepts LOADs and byte-compiles files on the fly."
  :group 'internal)

(defcustom bcc-enabled t
  "Non-nil means compile and cache all uncompiled Emacs Lisp files on load.
Files are cached to `bcc-cache-directory', unless matching a regular expression
in `bcc-blacklist'.

Also, \"on load\" means on the `load' function loading those files by calling
`load-source-file-function', which this feature redefines from the default
`load-source-file' to `bcc-load-source-file'."
  :type 'boolean
  :group 'byte-code-cache)

(defcustom bcc-cache-directory
  (file-name-as-directory (expand-file-name "byte-cache" user-emacs-directory))
  "Directory to which we store cached byte-compiled files."
  :type 'directory
  :group 'byte-code-cache)

(defcustom bcc-blacklist '("/\\.recentf$" "/history$")
  "List of regular expressions matching files that should
not be cached. Files that are modified every time Emacs
is run are good candidates for this list."
  :type '(repeat regexp)
  :group 'byte-code-cache)

;;; Variables:
(defvar bcc-old-load-source-file-function
  (if (boundp 'load-source-file-function)
      load-source-file-function
    (error "byte-code-cache requires LOAD-SOURCE-FILE-FUNCTION"))
  "Saved LOAD-SOURCE-FILE-FUNCTION")

(defvar bcc-regenerate-toplevel t
  "t unless we're inside BCC-REGENERATE-CACHE")

(defvar bcc-loaded-fake-cache-entry nil
  "Internal. Fake cache entries set this to t to indicate that
BCC-LOAD-SOURCE-FILE should load the original file.")

(defvar bcc-loaded nil
  "List of files loaded with bcc-load-source-file. List of conses.
car is origname, cdr is cachename.")

;;; Constants:
(defconst bcc-compiled-doc-string 4
  "From lisp.h")

;;; Load functions:
(defun bcc-load-source-file (fullname file &optional noerror nomessage)
  "Load Emacs Lisp FILE with absolute FULLNAME. If this file is not a compiled
Emacs Lisp file, has not already been compiled and cached by `byte-code-cache',
or has already been compiled and cached by `byte-code-cache' but the contents
of the uncompiled file have been modified since that compilation, compile the
file, cache the compiled file to `bcc-cache-directory', and load it.

If optional NOERROR is nil, signal `file-error' on error; otherwise, return nil.
If optional NOMESSAGE is nil, print informative messages at the start and end
of compilation; otherwise, do not.

This function has the same function specification as described by the
`load-source-file-function' variable. This feature sets that variable to this
function on feature load so as to enable byte-code compilation for all loaded
features, everywhere. (Quite a helpful variable, that...)"
  ;; This function is on the fast path. It also needs to be re-entrant.
  (let (hist-ent loaded-from-bcc-cache
        bcc-loaded-fake-cache-entry)
    (when (and bcc-enabled
               (not (save-match-data
                      (bcc-string-match-list bcc-blacklist fullname))))
      (let ((cache-file-name
             (bcc-make-cached-file fullname noerror nomessage)))
        ; FIXME: Shouldn't this always be the case? Signal an error or
        ; assertion if not.
        (when (file-readable-p  cache-file-name)
          (bcc-load-cached-file cache-file-name fullname noerror nomessage)
          (unless bcc-loaded-fake-cache-entry
            (setq loaded-from-bcc-cache t)))))
    (unless loaded-from-bcc-cache
      (funcall bcc-old-load-source-file-function
               fullname file noerror nomessage))))

(defun bcc-make-cached-file (plain-file-name &optional noerror nomessage)
  "Compile and cache uncompiled absolute PLAIN-FILE-NAME. Return the absolute
filename for the newly compiled and cached file, which is guaranteed to be a
file residing under `bcc-cache-directory'. (See `bcc-cache-file-name' for the
full algorithm.)

If optional NOERROR is nil, signal `file-error' on error; otherwise, return nil.
If optional NOMESSAGE is nil, print informative messages at the start and end
of compilation; otherwise, do not.

This function only compiles PLAIN-FILE-NAME when necessary: that is, when this
file is not a compiled file and has not been already compiled and cached or has
already been compiled and cached but the contents of the uncompiled file have
been modified since that compilation. compile the
file, cache the compiled file to , and load it."
  (let ((cache-file-name (file-truename
                          (bcc-cache-file-name plain-file-name))))
    (when (and bcc-regenerate-toplevel
               (file-newer-than-file-p plain-file-name cache-file-name)
      ; Recompile and cache the file, as its compiled version either did not
      ; exist or was older than this file.
      (make-directory (file-name-directory cache-file-name) :make-parents)
      (bcc-regenerate-cache plain-file-name cache-file-name nil)))
    cache-file-name))

(defun bcc-load-cached-file
  (cache-file-name plain-file-name &optional noerror nomessage)
  "Load compiled CACHE-FILE-NAME but pretend we're loading PLAIN-FILE-NAME.
CACHE-FILE-NAME and PLAIN-FILE-NAME are both absolute filenames.

If optional NOERROR is nil, signal `file-error' on error; otherwise, return nil.
If optional NOMESSAGE is nil, print informative messages at the start and end
of compilation; otherwise, do not.

We define this function instead of just using `load', since that primitive
unconditionally sets `load-file-name' to CACHE-FILE-NAME. CACHE-FILE-NAME
usually resides in a different directory than the original uncompiled file.
However, some Emacs Lisp files expect the file provided by `load-file-name' to
reside in the same directory as their original uncompiled file. This is a
reasonable expectation. This function corrects that by unconditionally setting
`load-file-name' to PLAIN-FILE-NAME.

This function also does away with `load-history' manipulation by loading files
\"directly,\" here.
  
This function is patterned on `load-with-code-conversion'. Compiled Emacs Lisp
files always use the interal Emacs encoding, as defined by `lread.c'."
  ;; This function is on the fast path, and it needs to be re-entrant.
  (if (null (file-readable-p cache-file-name))
      (and (null noerror)
           (signal 'file-error (list "Cannot open load file" cache-file-name)))
    (let* ((default-major-mode 'fundamental-mode)
           (default-enable-multibyte-characters nil)
           (buffer (get-buffer-create (generate-new-buffer-name " *load*")))
           (load-in-progress t)
           ;; BYTE-COMPILER-WARNINGS is sometimes unbound even though
           ;; (featurep 'bytecomp) is true. This happens when we're
           ;; loading custom files, since BYTE-COMPILER-WARNINGS is a
           ;; customization variable. Advice notices that bytecomp is
           ;; loaded and tries to compile advised functions, which
           ;; fails because we're in some strange customize-induced
           ;; twilight zone.
           (ad-default-compilation-action
            (if (and (featurep 'bytecomp)
                     (not (boundp 'byte-compiler-warnings)))
                'never
              ad-default-compilation-action)))
      (unless nomessage
        (message "Loading %S as %S..." cache-file-name plain-file-name))
      (unwind-protect
          (let ((load-file-name plain-file-name)
                (inhibit-file-name-operation nil))
            (with-current-buffer buffer
              (let ((coding-system-for-read 'no-conversion)
                    deactivate-mark
                    buffer-undo-list)
                (insert-file-contents cache-file-name)
                (set-buffer-multibyte nil)))
            (setq bcc-loaded
                  (cons (cons plain-file-name cache-file-name) bcc-loaded))
            (eval-buffer buffer nil plain-file-name nil t))
        (bcc-kill-buffer-unconditionally buffer))
      (do-after-load-evaluation plain-file-name)
      (unless nomessage
        (message "Loading %S as %S...done" cache-file-name plain-file-name))
      t)))

;;; Compilation functions:
(defun bcc-regenerate-cache
  (input-file-name cache-file-name &optional nomessage)
  "Compile non-byte-code INPUT-FILE-NAME into byte-code CACHE-FILE-NAME. Both
INPUT-FILE-NAME and CACHE-FILE-NAME must be absolute filenames.

If optional NOMESSAGE is nil, print informative messages at the start and end
of compilation; otherwise, do not.

If INPUT-FILE-NAME cannot be compiled, generate a fake cache entry instead.

This function is the top-level function for performing bytecode compilation. It
manages file and directory deletion and creation, as well as maintenance of
\"fake cache\" entries. (See `bcc-make-fake-cache-entry'.)"
  ;; This function is not on the fast path.
  (unless nomessage
    (message "Regenerating cache for %s" input-file-name))
  (let ((byte-compile-verbose nil)
        (font-lock-verbose nil)
        (byte-compile-warnings '())
        (kill-buffer-query-functions '())
        ;; `byte-comp' (for some reason) sets the mode in its `input-file-name'
        ;; buffer to `emacs-lisp-mode'. That mode's hook might load code that
        ;; needs to be compiled using this very function. We temporarily nullify
        ;; that hook to avoid a recursive situation.
        (emacs-lisp-mode-hook '())
        ;; Make sure we don't enter `byte-compile-file' recursively.
        (bcc-regenerate-toplevel nil))
    (let ((buf (find-buffer-visiting cache-file-name)))
      (when buf (bcc-kill-buffer-unconditionally buf)))
    ; Delete `cache-file-name', if that file exists.
    (when (file-exists-p cache-file-name) (delete-file cache-file-name))
    ; Compile `input-file-name' to `cache-file-name'.
    (bcc-byte-compile-file input-file-name cache-file-name)
    ; If `input-file-name' cannot be compiled, make a "fake" cache file for it.
    (unless (file-readable-p cache-file-name)
      (unless nomessage
        (message "Making fake cache entry for %S" cache-file-name))
      (bcc-make-fake-cache-entry cache-file-name input-file-name)))
  (unless nomessage
    (message "Regenerating cache for %s...done" input-file-name)))

(defun bcc-byte-compile-file (input-file-name output-file-name)
  "Compiles INPUT-FILE-NAME to OUTPUT-FILE-NAME. Return the result of
calling `byte-compile-file' with this input filename. (This function is a
wrapper around `byte-compile-file', which provides no means of specifying the
output filename as a function argument.)"
  (let ((saved-dest-func (symbol-function #'byte-compile-dest-file)))
    (unwind-protect
        (progn
          (fset #'byte-compile-dest-file
                #'(lambda (src)
                    (if (equal src input-file-name)
                        output-file-name
                      (funcall saved-dest-func src))))
          (byte-compile-file input-file-name))
      (fset #'byte-compile-dest-file saved-dest-func))))

(defun bcc-make-fake-cache-entry (cache-file-name plain-file-name)
  "Creates a compiled CACHE-FILE-NAME that simply loads PLAIN-FILE-NAME. Thus,
the compiled filename is now a \"fake entry\" for the uncompiled filename.

`bcc-regenerate-cache' calls this function for uncompiled files that cannot be
compiled, due to receiving errors when trying to compile them."
  ;; This function is not on the fast path.
  (let ((byte-compile-verbose nil)
        (font-lock-verbose nil)
        (byte-compile-warnings '())
        (temp-file
         (make-temp-file
          (expand-file-name "fake-cache-"
                            (or small-temporary-file-directory
                                temporary-file-directory))
          nil
          ".el")))
    (unwind-protect
        (progn
          (with-temp-file temp-file
            (prin1 `(setq bcc-loaded-fake-cache-entry t)
                   (current-buffer)))
          (bcc-byte-compile-file temp-file cache-file-name)
          (bcc-assert (file-readable-p cache-file-name)))
      (delete-file temp-file))))

;;; Documentation advice:
(defadvice documentation-property
  (before bcc-documentation-property-fix activate)
  "Work around an Emacs bug."
  (let ((docobj (get (ad-get-arg 0) (ad-get-arg 1)))
        loadinfo)
    (when (and (numberp (cdr-safe docobj))
               (setq loadinfo (assoc (car docobj) bcc-loaded)))
      (setcar docobj (cdr loadinfo)))))

(defadvice documentation
  (before bcc-documentation-fix activate preactivate)
  "Work around an Emacs bug."
  (let* ((fun (ad-get-arg 0))
         docobj loadinfo funcar prop)
    (if (and (symbolp fun)
             (setq prop (get fun 'function-documentation)))
        ;; Called for side-effect
        (documentation-property fun 'function-documentation (ad-get-arg 1))
      (setq fun (indirect-function fun t))
      (setq funcar (car-safe fun))
      (when (eq funcar 'macro)
        (setq fun (indirect-function (cdr fun)))
        (setq funcar (car-safe fun)))
      (cond ((memq funcar '(lambda autoload))
             (setq docobj (car (cdr (cdr fun)))))
            ((and (byte-code-function-p fun)
                  (> (length fun) bcc-compiled-doc-string))
             (setq docobj (aref fun bcc-compiled-doc-string))))
      (when (and (consp docobj)
                 (setq loadinfo (assoc (car docobj) bcc-loaded)))
        (setcar docobj (cdr loadinfo))))))

;;; Buffer utilities:
(defun bcc-kill-buffer-unconditionally (buffer)
  "Kill BUFFER without querying the user or running `kill-buffer-hook'."
  (when (buffer-modified-p buffer)
    (with-current-buffer buffer (restore-buffer-modified-p nil)))
  (let (kill-buffer-hook kill-buffer-query-functions)
    (kill-buffer buffer)))

;;; String utilities:
(defun bcc-string-match-list (re-list string)
  "Return non-nil if STRING matches at least one regular expression in RE-LIST.
This function overwrites without saving existing regular expression match data,
since this function calls itself recursively and since saving match data for
each such recursive call is prohibitively expensive."
  (cond
   ((null re-list) nil)
   ((string-match (car re-list) string))
   (t (bcc-string-match-list (cdr re-list) string))))

;;; Path utilities:
(defun bcc-cache-file-name (file-name)
  "Return absolute cache directory filename for this absolute FILE-NAME.
This is an absolute filename under `bcc-cache-directory' ending in extension
\".elc\"."
  (concat
   (file-name-as-directory (expand-file-name bcc-cache-directory))
   (bcc-cache-directory-name-to-file-name
    (file-name-sans-extension (file-relative-name file-name "/")))
   ".elc"))

(defun bcc-cache-directory-name-to-file-name (directory-name)
  "Return the reversible filename corresponding to this absolute DIRECTORY-NAME.
Specifically:

* Convert Windows-style \"${DRIVE_LETTER}:\" prefix strings into
  \"/drive_${DRIVE_LETTER}\" strings.
* Convert directory seperator characters into '!' characters.

This filename is \"reversible\" back into this original absolute DIRECTORY-NAME,
though that has not been implemented. 

This function's implementation is marginally inspired by that of both
`cedet-directory-name-to-file-name' and `make-backup-file-name-1'."
  ;; Normalize DOSish file names: downcase the drive letter, if any, and
  ;; replace the leading "x:" with "/drive_x".
  (when (memq system-type '(windows-nt ms-dos cygwin))
    (or (file-name-absolute-p directory-name)
        (setq directory-name
              (expand-file-name directory-name))) ; make defaults explicit
    ;; Replace any invalid file-name characters (for the
    ;; case of backing up remote files).
    (setq directory-name
          (expand-file-name (convert-standard-filename directory-name)))
    (if (eq (aref directory-name 1) ?:)
        (setq directory-name
              (concat "/"
                      "drive_"
                      (char-to-string (downcase (aref directory-name 0)))
                      (if (eq (aref directory-name 2) ?/)
                          ""
                        "/")
                      (substring directory-name 2)))))
  ;; Make the name unique by substituting directory separators. It may not
  ;; really be worth bothering about doubling `!'s in the original name.
  (subst-char-in-string
   ?/ ?!
   (replace-regexp-in-string "!" "!!" directory-name)))

;;; Debug utilities:
;FIXME: This macro only called once. We can probably do away with it. If we do
;keep it, it should be corrected so as to turn into a no-op under the same
;conditions that the Common Lisp `assert' macro turns into a no-op.
(defmacro bcc-assert (expr)
  "Like ASSERT, but doesn't depend on CL"
  `(or ,expr (signal 'bcc-assert-failed (list ',expr))))

;FIXME: This function never called. Was it intended to be? If not, remove.
;; Life is ugly without CL. We need to avoid it in order to not
;; trigger recursive-load loops. In fact, we need to avoid anything
;; autoloaded, and anything not in the Emacs core.
;; (defun bcc-alist-member-delete-all (alist &rest keys)
;;   "Delete from ALIST all elements whose car is `equal' to any element in KEYS.
;; Return the modified alist. Elements of ALIST that are not conses
;; are ignored."
;;   (while (and (consp (car alist))
;;               (member (car (car alist)) keys))
;;     (setq alist (cdr alist)))
;;   (let ((tail alist) tail-cdr)
;;     (while (setq tail-cdr (cdr tail))
;;       (if (and (consp (car tail-cdr))
;;                (member (car (car tail-cdr)) keys))
;;           (setcdr tail (cdr tail-cdr))
;;         (setq tail tail-cdr))))
;;   alist)

;;; Top-level forms:
(setq load-source-file-function #'bcc-load-source-file)
(provide 'byte-code-cache)

;;; byte-code-cache.el ends here.