guix/build/asdf-build-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix build asdf-build-system)
  20   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  21   #:use-module (guix build utils)
  22   #:use-module (guix build lisp-utils)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-11)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (ice-9 rdelim)
  27   #:use-module (ice-9 receive)
  28   #:use-module (ice-9 regex)
  29   #:use-module (ice-9 match)
  30   #:use-module (ice-9 format)
  31   #:use-module (ice-9 ftw)
  32   #:export (%standard-phases
  33             %standard-phases/source
  34             asdf-build
  35             asdf-build/source))
  36
  37 ;; Commentary:
  38 ;;
  39 ;; System for building ASDF packages; creating executable programs and images
  40 ;; from them.
  41 ;;
  42 ;; Code:
  43
  44 (define %object-prefix "/lib")
  45
  46 (define (%lisp-source-install-prefix)
  47   (string-append %source-install-prefix "/" (%lisp-type) "-source"))
  48
  49 (define %system-install-prefix
  50   (string-append %source-install-prefix "/systems"))
  51
  52 (define (lisp-source-directory output name)
  53   (string-append output (%lisp-source-install-prefix) "/" name))
  54
  55 (define (source-directory output name)
  56   (string-append output %source-install-prefix "/source/" name))
  57
  58 (define (library-directory output)
  59   (string-append output %object-prefix
  60                  "/" (%lisp-type)))
  61
  62 (define (output-translation source-path
  63                             object-output)
  64   "Return a translation for the system's source path
  65 to it's binary output."
  66   `((,source-path
  67      :**/ :*.*.*)
  68     (,(library-directory object-output)
  69      :**/ :*.*.*)))
  70
  71 (define (source-asd-file output name asd-file)
  72   (string-append (lisp-source-directory output name) "/" asd-file))
  73
  74 (define (copy-files-to-output out name)
  75   "Copy all files from the current directory to OUT.  Create an extra link to
  76 any system-defining files in the source to a convenient location.  This is
  77 done before any compiling so that the compiled source locations will be
  78 valid."
  79   (let ((source (getcwd))
  80         (target (source-directory out name))
  81         (system-path (string-append out %system-install-prefix)))
  82     ;; SBCL keeps the modification time of the source file in the compiled
  83     ;; file, and the source files might just have been patched by a custom
  84     ;; phase. Therefore we reset the modification time of all the source
  85     ;; files before compiling.
  86     (for-each (lambda (file)
  87                 (let ((s (lstat file)))
  88                   (unless (or (eq? (stat:type s) 'symlink)
  89                               (not (access? file W_OK)))
  90                     (utime file 0 0 0 0))))
  91               (find-files source #:directories? #t))
  92     (copy-recursively source target #:keep-mtime? #t)
  93     (mkdir-p system-path)
  94     (for-each
  95      (lambda (file)
  96        (symlink file
  97                 (string-append system-path "/" (basename file))))
  98      (find-files target "\\.asd$"))
  99     #t))
 100
 101 (define* (install #:key inputs outputs #:allow-other-keys)
 102   "Copy and symlink all the source files.
 103 The source files are taken from the corresponding compile package (e.g. SBCL)
 104 if it's present in the native-inputs."
 105   (define output (assoc-ref outputs "out"))
 106   (define package-name
 107     (package-name->name+version
 108      (strip-store-file-name output)))
 109   (define (no-prefix pkgname)
 110     (if (string-index pkgname #\-)
 111         (string-drop pkgname (1+ (string-index pkgname #\-)))
 112         pkgname))
 113   (define parent
 114     (match (assoc package-name inputs
 115                   (lambda (key alist-car)
 116                     (let* ((alt-key (no-prefix key))
 117                            (alist-car (no-prefix alist-car)))
 118                       (or (string=? alist-car key)
 119                           (string=? alist-car alt-key)))))
 120       (#f #f)
 121       (p (cdr p))))
 122   (define parent-name
 123     (and parent
 124          (package-name->name+version (strip-store-file-name parent))))
 125   (define parent-source
 126     (and parent
 127          (string-append parent "/share/common-lisp/"
 128                         (string-take parent-name
 129                                      (string-index parent-name #\-))
 130                         "-source")))
 131
 132   (define (first-subdirectory directory) ; From gnu-build-system.
 133     "Return the file name of the first sub-directory of DIRECTORY."
 134     (match (scandir directory
 135                     (lambda (file)
 136                       (and (not (member file '("." "..")))
 137                            (file-is-directory? (string-append directory "/"
 138                                                               file)))))
 139       ((first . _) first)))
 140   (define source-directory
 141     (if (and parent-source
 142              (file-exists? parent-source))
 143         (string-append parent-source "/" (first-subdirectory parent-source))
 144         "."))
 145
 146   (with-directory-excursion source-directory
 147     (copy-files-to-output output package-name)))
 148
 149 (define* (copy-source #:key outputs asd-system-name #:allow-other-keys)
 150   "Copy the source to the library output."
 151   (let* ((out (library-output outputs))
 152          (install-path (string-append out %source-install-prefix)))
 153     (copy-files-to-output out asd-system-name)
 154     ;; Hide the files from asdf
 155     (with-directory-excursion install-path
 156       (rename-file "source" (string-append (%lisp-type) "-source"))
 157       (delete-file-recursively "systems")))
 158   #t)
 159
 160 (define* (build #:key outputs inputs asd-file asd-system-name
 161                 #:allow-other-keys)
 162   "Compile the system."
 163   (let* ((out (library-output outputs))
 164          (source-path (lisp-source-directory out asd-system-name))
 165          (translations (wrap-output-translations
 166                         `(,(output-translation source-path
 167                                                out))))
 168          (asd-file (source-asd-file out asd-system-name asd-file)))
 169
 170     (setenv "ASDF_OUTPUT_TRANSLATIONS"
 171             (replace-escaped-macros (format #f "~S" translations)))
 172
 173     (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
 174
 175     (compile-system asd-system-name asd-file)
 176
 177     ;; As above, ecl will sometimes create this even though it doesn't use it
 178
 179     (let ((cache-directory (string-append out "/.cache")))
 180       (when (directory-exists? cache-directory)
 181         (delete-file-recursively cache-directory))))
 182   #t)
 183
 184 (define* (check #:key tests? outputs inputs asd-file asd-system-name
 185                 test-asd-file
 186                 #:allow-other-keys)
 187   "Test the system."
 188   (let* ((out (library-output outputs))
 189          (asd-file (source-asd-file out asd-system-name asd-file))
 190          (test-asd-file
 191           (and=> test-asd-file
 192                  (cut source-asd-file out asd-system-name <>))))
 193     (if tests?
 194         (test-system asd-system-name asd-file test-asd-file)
 195         (format #t "test suite not run~%")))
 196   #t)
 197
 198 (define* (create-asd-file #:key outputs
 199                           inputs
 200                           asd-file
 201                           asd-system-name
 202                           #:allow-other-keys)
 203   "Create a system definition file for the built system."
 204   (let*-values (((out) (library-output outputs))
 205                 ((_ version) (package-name->name+version
 206                               (strip-store-file-name out)))
 207                 ((new-asd-file) (string-append
 208                                  (library-directory out)
 209                                  "/" (normalize-string asd-system-name)
 210                                  ".asd")))
 211
 212     (make-asd-file new-asd-file
 213                    #:system asd-system-name
 214                    #:version version
 215                    #:inputs inputs
 216                    #:system-asd-file asd-file))
 217   #t)
 218
 219 (define* (symlink-asd-files #:key outputs #:allow-other-keys)
 220   "Create an extra reference to the system in a convenient location."
 221   (let* ((out (library-output outputs)))
 222     (for-each
 223      (lambda (asd-file)
 224        (receive (new-asd-file asd-file-directory)
 225            (bundle-asd-file out asd-file)
 226          (mkdir-p asd-file-directory)
 227          (symlink asd-file new-asd-file)
 228          ;; Update the source registry for future phases which might want to
 229          ;; use the newly compiled system.
 230          (prepend-to-source-registry
 231           (string-append asd-file-directory "/"))))
 232
 233      (find-files (string-append out %object-prefix) "\\.asd$")))
 234   #t)
 235
 236 (define* (cleanup-files #:key outputs
 237                         #:allow-other-keys)
 238   "Remove any compiled files which are not a part of the final bundle."
 239   (let ((out (library-output outputs)))
 240     (match (%lisp-type)
 241       ("sbcl"
 242        (for-each
 243         (lambda (file)
 244           (unless (string-suffix? "--system.fasl" file)
 245             (delete-file file)))
 246         (find-files out "\\.fasl$")))
 247       ("ecl"
 248        (for-each delete-file
 249                  (append (find-files out "\\.fas$")
 250                          (find-files out "\\.o$")))))
 251
 252     (with-directory-excursion (library-directory out)
 253       (for-each
 254        (lambda (file)
 255          (rename-file file
 256                       (string-append "./" (basename file))))
 257        (find-files "."))
 258       (for-each delete-file-recursively
 259                 (scandir "."
 260                          (lambda (file)
 261                            (and
 262                             (directory-exists? file)
 263                             (string<> "." file)
 264                             (string<> ".." file)))))))
 265   #t)
 266
 267 (define* (strip #:rest args)
 268   ;; stripping sbcl binaries removes their entry program and extra systems
 269   (or (string=? (%lisp-type) "sbcl")
 270       (apply (assoc-ref gnu:%standard-phases 'strip) args)))
 271
 272 (define %standard-phases/source
 273   (modify-phases gnu:%standard-phases
 274     (delete 'bootstrap)
 275     (delete 'configure)
 276     (delete 'check)
 277     (delete 'build)
 278     (replace 'install install)))
 279
 280 (define %standard-phases
 281   (modify-phases gnu:%standard-phases
 282     (delete 'bootstrap)
 283     (delete 'configure)
 284     (delete 'install)
 285     (replace 'build build)
 286     (add-before 'build 'copy-source copy-source)
 287     (replace 'check check)
 288     (replace 'strip strip)
 289     (add-after 'check 'create-asd-file create-asd-file)
 290     (add-after 'create-asd-file 'cleanup cleanup-files)
 291     (add-after 'cleanup 'create-symlinks symlink-asd-files)))
 292
 293 (define* (asdf-build #:key inputs
 294                      (phases %standard-phases)
 295                      #:allow-other-keys
 296                      #:rest args)
 297   (apply gnu:gnu-build
 298          #:inputs inputs
 299          #:phases phases
 300          args))
 301
 302 (define* (asdf-build/source #:key inputs
 303                             (phases %standard-phases/source)
 304                             #:allow-other-keys
 305                             #:rest args)
 306   (apply gnu:gnu-build
 307          #:inputs inputs
 308          #:phases phases
 309          args))
 310
 311 ;;; asdf-build-system.scm ends here