build-system: Add asdf-build-system.

* guix/build-system/asdf.scm: New file.
* guix/build/asdf-build-system.scm: New file.
* guix/build/lisp-utils.scm: New file.
* Makefile.am (MODULES): Add them.
* doc/guix.texi (Build Systems): Document 'asdf-build-system'.

Signed-off-by: 宋文武 <iyzsong@gmail.com>

1 files changed, 327 insertions, 0 deletions

diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
new file mode 100644
index 0000000000..55a07c7207
--- /dev/null
+++ b/guix/build/lisp-utils.scm
@@ -0,0 +1,327 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build lisp-utils)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (guix build utils)
+  #:export (%lisp
+            %install-prefix
+            lisp-eval-program
+            compile-system
+            test-system
+            replace-escaped-macros
+            generate-executable-wrapper-system
+            generate-executable-entry-point
+            generate-executable-for-system
+            patch-asd-file
+            bundle-install-prefix
+            lisp-dependencies
+            bundle-asd-file
+            remove-lisp-from-name
+            wrap-output-translations
+            prepend-to-source-registry
+            build-program
+            build-image))
+
+;;; Commentary:
+;;;
+;;; Tools to evaluate lisp programs within a lisp session, generate wrapper
+;;; systems for executables. Compile, test, and produce images for systems and
+;;; programs, and link them with their dependencies.
+;;;
+;;; Code:
+
+(define %lisp
+  ;; File name of the Lisp compiler.
+  (make-parameter "lisp"))
+
+(define %install-prefix "/share/common-lisp")
+
+(define (bundle-install-prefix lisp)
+  (string-append %install-prefix "/" lisp "-bundle-systems"))
+
+(define (remove-lisp-from-name name lisp)
+  (string-drop name (1+ (string-length lisp))))
+
+(define (wrap-output-translations translations)
+  `(:output-translations
+    ,@translations
+    :inherit-configuration))
+
+(define (lisp-eval-program lisp program)
+  "Evaluate PROGRAM with a given LISP implementation."
+  (unless (zero? (apply system*
+                        (lisp-invoke lisp (format #f "~S" program))))
+    (error "lisp-eval-program failed!" lisp program)))
+
+(define (lisp-invoke lisp program)
+  "Return a list of arguments for system* determining how to invoke LISP
+with PROGRAM."
+  (match lisp
+    ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
+    ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))))
+
+(define (asdf-load-all systems)
+  (map (lambda (system)
+         `(funcall
+           (find-symbol
+            (symbol-name :load-system)
+            (symbol-name :asdf))
+           ,system))
+       systems))
+
+(define (compile-system system lisp asd-file)
+  "Use a lisp implementation to compile SYSTEM using asdf.  Load ASD-FILE
+first if SYSTEM is defined there."
+  (lisp-eval-program lisp
+                     `(progn
+                       (require :asdf)
+                       (in-package :asdf)
+                       ,@(if asd-file
+                             `((load ,asd-file))
+                             '())
+                       (in-package :cl-user)
+                       (funcall (find-symbol
+                                 (symbol-name :operate)
+                                 (symbol-name :asdf))
+                                (find-symbol
+                                 (symbol-name :compile-bundle-op)
+                                 (symbol-name :asdf))
+                                ,system)
+                       (funcall (find-symbol
+                                 (symbol-name :operate)
+                                 (symbol-name :asdf))
+                                (find-symbol
+                                 (symbol-name :deliver-asd-op)
+                                 (symbol-name :asdf))
+                                ,system))))
+
+(define (test-system system lisp asd-file)
+  "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILE first
+if SYSTEM is defined there."
+  (lisp-eval-program lisp
+                     `(progn
+                       (require :asdf)
+                       (in-package :asdf)
+                       ,@(if asd-file
+                             `((load ,asd-file))
+                             '())
+                       (in-package :cl-user)
+                       (funcall (find-symbol
+                                 (symbol-name :test-system)
+                                 (symbol-name :asdf))
+                                ,system))))
+
+(define (string->lisp-keyword . strings)
+  "Return a lisp keyword for the concatenation of STRINGS."
+  (string->symbol (apply string-append ":" strings)))
+
+(define (generate-executable-for-system type system lisp)
+  "Use LISP to generate an executable, whose TYPE can be \"image\" or
+\"program\".  The latter will always be standalone.  Depends on having created
+a \"SYSTEM-exec\" system which contains the entry program."
+  (lisp-eval-program
+   lisp
+   `(progn
+     (require :asdf)
+     (funcall (find-symbol
+               (symbol-name :operate)
+               (symbol-name :asdf))
+              (find-symbol
+               (symbol-name ,(string->lisp-keyword type "-op"))
+               (symbol-name :asdf))
+              ,(string-append system "-exec")))))
+
+(define (generate-executable-wrapper-system system dependencies)
+  "Generates a system which can be used by asdf to produce an image or program
+inside the current directory.  The image or program will contain
+DEPENDENCIES."
+  (with-output-to-file (string-append system "-exec.asd")
+    (lambda _
+      (format #t "~y~%"
+              `(defsystem ,(string->lisp-keyword system "-exec")
+                 :entry-point ,(string-append system "-exec:main")
+                 :depends-on (:uiop
+                              ,@(map string->lisp-keyword
+                                     dependencies))
+                 :components ((:file ,(string-append system "-exec"))))))))
+
+(define (generate-executable-entry-point system entry-program)
+  "Generates an entry point program from the list of lisp statements
+ENTRY-PROGRAM for SYSTEM within the current directory."
+  (with-output-to-file (string-append system "-exec.lisp")
+    (lambda _
+      (let ((system (string->lisp-keyword system "-exec")))
+        (format #t "~{~y~%~%~}"
+                `((defpackage ,system
+                    (:use :cl)
+                    (:export :main))
+
+                  (in-package ,system)
+
+                  (defun main ()
+                    (let ((arguments uiop:*command-line-arguments*))
+                      (declare (ignorable arguments))
+                      ,@entry-program))))))))
+
+(define (wrap-perform-method lisp registry dependencies file-name)
+  "Creates a wrapper method which allows the system to locate its dependent
+systems from REGISTRY, an alist of the same form as %outputs, which contains
+lisp systems which the systems is dependent on.  All DEPENDENCIES which the
+system depends on will the be loaded before this system."
+  (let* ((system (string-drop-right (basename file-name) 4))
+         (system-symbol (string->lisp-keyword system)))
+
+    `(defmethod asdf:perform :before
+       (op (c (eql (asdf:find-system ,system-symbol))))
+       (asdf/source-registry:ensure-source-registry)
+       ,@(map (match-lambda
+                ((name . path)
+                 (let ((asd-file (string-append path
+                                                (bundle-install-prefix lisp)
+                                                "/" name ".asd")))
+                   `(setf
+                     (gethash ,name
+                              asdf/source-registry:*source-registry*)
+                     ,(string->symbol "#p")
+                     ,(bundle-asd-file path asd-file lisp)))))
+              registry)
+       ,@(map (lambda (system)
+                `(asdf:load-system ,(string->lisp-keyword system)))
+              dependencies))))
+
+(define (patch-asd-file asd-file registry lisp dependencies)
+  "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD."
+  (chmod asd-file #o644)
+  (let ((port (open-file asd-file "a")))
+    (dynamic-wind
+      (lambda _ #t)
+      (lambda _
+        (display
+         (replace-escaped-macros
+          (format #f "~%~y~%"
+                  (wrap-perform-method lisp registry
+                                       dependencies asd-file)))
+         port))
+      (lambda _ (close-port port))))
+  (chmod asd-file #o444))
+
+(define (lisp-dependencies lisp inputs)
+  "Determine which inputs are lisp system dependencies, by using the convention
+that a lisp system dependency will resemble \"system-LISP\"."
+  (filter-map (match-lambda
+                ((name . value)
+                 (and (string-prefix? lisp name)
+                      (string<> lisp name)
+                      `(,(remove-lisp-from-name name lisp)
+                        . ,value))))
+              inputs))
+
+(define (bundle-asd-file output-path original-asd-file lisp)
+  "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
+OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd.  Returns two
+values: the asd file itself and the directory in which it resides."
+  (let ((bundle-asd-path (string-append output-path
+                                        (bundle-install-prefix lisp))))
+    (values (string-append bundle-asd-path "/" (basename original-asd-file))
+            bundle-asd-path)))
+
+(define (replace-escaped-macros string)
+  "Replace simple lisp forms that the guile writer escapes, for example by
+replacing #{#p}# with #p.  Should only be used to replace truly simple forms
+which are not nested."
+  (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
+                            'pre 2 'post))
+
+(define (prepend-to-source-registry path)
+  (setenv "CL_SOURCE_REGISTRY"
+          (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
+
+(define* (build-program lisp program #:key inputs
+                        (dependencies (list (basename program)))
+                        entry-program
+                        #:allow-other-keys)
+  "Generate an executable program containing all DEPENDENCIES, and which will
+execute ENTRY-PROGRAM.  The result is placed in PROGRAM.  When executed, it
+will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
+has been bound to the command-line arguments which were passed."
+  (generate-executable lisp program
+                       #:inputs inputs
+                       #:dependencies dependencies
+                       #:entry-program entry-program
+                       #:type "program")
+  (let* ((name (basename program))
+         (bin-directory (dirname program)))
+    (with-directory-excursion bin-directory
+      (rename-file (string-append name "-exec")
+                   name)))
+  #t)
+
+(define* (build-image lisp image #:key inputs
+                      (dependencies (list (basename image)))
+                      #:allow-other-keys)
+  "Generate an image, possibly standalone, which contains all DEPENDENCIES,
+placing the result in IMAGE.image."
+  (generate-executable lisp image
+                       #:inputs inputs
+                       #:dependencies dependencies
+                       #:entry-program '(nil)
+                       #:type "image")
+  (let* ((name (basename image))
+         (bin-directory (dirname image)))
+    (with-directory-excursion bin-directory
+      (rename-file (string-append name "-exec--all-systems.image")
+                   (string-append name ".image"))))
+  #t)
+
+(define* (generate-executable lisp out-file #:key inputs
+                              dependencies
+                              entry-program
+                              type
+                              #:allow-other-keys)
+  "Generate an executable by using asdf's TYPE-op, containing whithin the
+image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
+executable."
+  (let* ((bin-directory (dirname out-file))
+         (name (basename out-file)))
+    (mkdir-p bin-directory)
+    (with-directory-excursion bin-directory
+      (generate-executable-wrapper-system name dependencies)
+      (generate-executable-entry-point name entry-program))
+
+    (prepend-to-source-registry
+     (string-append bin-directory "/"))
+
+    (setenv "ASDF_OUTPUT_TRANSLATIONS"
+            (replace-escaped-macros
+             (format
+              #f "~S"
+              (wrap-output-translations
+               `(((,bin-directory :**/ :*.*.*)
+                  (,bin-directory :**/ :*.*.*)))))))
+
+    (parameterize ((%lisp (string-append
+                           (assoc-ref inputs lisp) "/bin/" lisp)))
+      (generate-executable-for-system type name lisp))
+
+    (delete-file (string-append bin-directory "/" name "-exec.asd"))
+    (delete-file (string-append bin-directory "/" name "-exec.lisp"))))