nixpkgs/pkgs/development/lisp-modules/quicklisp-to-nix/util.lisp

(defpackage :ql-to-nix-util
  (:use :common-lisp)
  (:export #:nix-prefetch-url #:wrap #:pathname-as-directory #:copy-directory-tree #:with-temporary-directory #:sym #:with-temporary-asdf-cache #:with-asdf-cache)
  (:documentation
   "A collection of useful functions and macros that ql-to-nix will use."))
(in-package :ql-to-nix-util)

(declaim (optimize (debug 3) (speed 0) (space 0) (compilation-speed 0) (safety 3)))

;; This file cannot have any dependencies beyond quicklisp and asdf.
;; Otherwise, we'll miss some dependencies!

(defun pathname-as-directory (pathname)
  "Given a pathname, make it into a path to a directory.

This is sort of like putting a / at the end of the path."
  (unless (pathname-name pathname)
    (return-from pathname-as-directory pathname))
  (let* ((old-dir (pathname-directory pathname))
         (old-name (pathname-name pathname))
         (old-type (pathname-type pathname))
         (last-dir
          (cond
            (old-type
             (format nil "~A.~A" old-name old-type))
            (t
             old-name)))
         (new-dir (if old-dir
                      (concatenate 'list old-dir (list last-dir))
                      (list :relative last-dir))))

    (make-pathname :name nil :directory new-dir :type nil :defaults pathname)))

(defvar *nix-prefetch-url-bin*
  (namestring (merge-pathnames #P"bin/nix-prefetch-url" (pathname-as-directory (uiop:getenv "nix-prefetch-url"))))
  "The path to the nix-prefetch-url binary")

(defun nix-prefetch-url (url &key expected-sha256)
  "Invoke the nix-prefetch-url program.

Returns a plist with two keys.
:sha256 => The sha of the fetched file
:path => The path to the file in the nix store"
  (when expected-sha256
    (setf expected-sha256 (list expected-sha256)))
  (let* ((stdout
          (with-output-to-string (so)
            (uiop:run-program
             `(,*nix-prefetch-url-bin* "--print-path" ,url ,@expected-sha256)
             :output so)))
         (stream (make-string-input-stream stdout)))
    (list
     :sha256 (read-line stream)
     :path (read-line stream))))

(defmacro wrap (package symbol-name)
  "Create a function which looks up the named symbol at runtime and
invokes it with the same arguments.

If you can't load a system until runtime, this macro gives you an
easier way to write
    (funcall (intern \"SYMBOL-NAME\" :package-name) arg)
Instead, you can write
    (wrap :package-name symbol-name)
    (symbol-name arg)"
  (let ((args (gensym "ARGS")))
    `(defun ,symbol-name (&rest ,args)
       (apply (sym ',package ',symbol-name) ,args))))

(defun copy-directory-tree (src-dir target-dir)
  "Recursively copy every file in `src-dir' into `target-dir'.

This function traverses symlinks."
  (when (or (not (pathname-directory target-dir))
            (pathname-name target-dir))
    (error "target-dir must be a dir"))
  (when (or (not (pathname-directory src-dir))
            (pathname-name src-dir))
    (error "src-dir must be a dir"))
  (let ((src-wild (make-pathname :name :wild :type :wild :defaults src-dir)))
    (dolist (entity (uiop:directory* src-wild))
      (if (pathname-name entity)
          (uiop:copy-file entity (make-pathname :type (pathname-type entity) :name (pathname-name entity) :defaults target-dir))
          (let ((new-target-dir
                 (make-pathname
                  :directory (concatenate 'list (pathname-directory target-dir) (last (pathname-directory entity))))))
            (ensure-directories-exist new-target-dir)
            (copy-directory-tree entity new-target-dir))))))

(defun call-with-temporary-directory (function)
  "Create a temporary directory, invoke the given function by passing
in the pathname for the directory, and then delete the directory."
  (let* ((dir (uiop:run-program '("mktemp" "-d") :output :line))
         (parsed (parse-namestring dir))
         (parsed-as-dir (pathname-as-directory parsed)))
    (assert (uiop:absolute-pathname-p dir))
    (unwind-protect
         (funcall function parsed-as-dir)
      (uiop:delete-directory-tree
       parsed-as-dir
       :validate
       (lambda (path)
         (and (uiop:absolute-pathname-p path)
              (equal (subseq (pathname-directory path) 0 (length (pathname-directory parsed-as-dir)))
                     (pathname-directory parsed-as-dir))))))))

(defmacro with-temporary-directory ((dir-name) &body body)
  "See `call-with-temporary-directory'."
  `(call-with-temporary-directory (lambda (,dir-name) ,@body)))

(defun sym (package sym)
  "A slightly less picky version of `intern'.

Unlike `intern', the `sym' argument can be a string or a symbol.  If
it is a symbol, then the `symbol-name' is `intern'ed into the
specified package.

The arguments are also reversed so that the package comes first."
  (etypecase sym
    (symbol (setf sym (symbol-name sym)))
    (string))
  (intern sym package))

(defvar *touch-bin*
  (namestring (merge-pathnames #P"bin/touch" (pathname-as-directory (uiop:getenv "touch"))))
  "Path to the touch binary.")

(defvar *cache-dir* nil
  "When asdf cache remapping is in effect (see `with-asdf-cache'),
this stores the path to the fasl cache directory.")
(defvar *src-dir* nil
  "When asdf cache remapping is in effect (see `with-asdf-cache'),
this stores the path to the source directory.

Only lisp files within the source directory will have their fasls
cached in the cache directory.")

(defun remap (path prefix)
  "Implements the cache policy described in `with-asdf-cache'."
  (declare (ignore prefix))
  (let* ((ql-dirs (pathname-directory *src-dir*))
         (ql-dirs-length (length ql-dirs))
         (path-prefix (subseq (pathname-directory path) 0 ql-dirs-length))
         (path-postfix (subseq (pathname-directory path) ql-dirs-length)))
    (unless (equal path-prefix ql-dirs)
      (return-from remap path))
    (let ((result (make-pathname :directory (concatenate 'list (pathname-directory *cache-dir*) path-postfix) :defaults path)))
      (with-open-file (s result :direction :probe :if-does-not-exist nil)
        (when s
          (uiop:run-program `(,*touch-bin* ,(namestring result)))))
      result)))

(defmacro with-temporary-asdf-cache ((src-dir) &body body)
  "Create a temporary directory, and then use it as the ASDF cache
directory for source files in `src-dir'.

See `with-asdf-cache'."
  (let ((tmp-dir (gensym "ORIGINAL-VALUE")))
    `(with-temporary-directory (,tmp-dir)
       (with-asdf-cache (,src-dir ,tmp-dir)
         ,@body))))

(defmacro with-asdf-cache ((src-dir cache-dir) &body body)
  "When ASDF compiles a lisp file in `src-dir', store the fasl in `cache-dir'."
  (let ((original-value (gensym "ORIGINAL-VALUE")))
    `(let ((,original-value asdf:*output-translations-parameter*)
           (*src-dir* ,src-dir)
           (*cache-dir* ,cache-dir))
       (unwind-protect
            (progn
              (asdf:initialize-output-translations
               '(:output-translations
                 :INHERIT-CONFIGURATION
                 ;; FIXME: Shouldn't we only be remaping things
                 ;; actually in the src dir?  Oh well.
                 (t (:function remap))))
              ,@body)
         (asdf:initialize-output-translations ,original-value)))))