unofficial mirror of bug-guix@gnu.org 
 help / color / mirror / code / Atom feed
blob 5a4fc44aef86b930a7d990defd578d397784330c 11151 bytes (raw)
name: guix/build/asdf-build-system.scm 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net>
;;;
;;; 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 asdf-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build union)
  #:use-module (guix build lisp-utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:export (%standard-phases
            %standard-phases/source
            asdf-build
            asdf-build/source))

;; Commentary:
;;
;; System for building ASDF packages; creating executable programs and images
;; from them.
;;
;; Code:

(define %object-prefix "/lib/common-lisp")

(define (%lisp-source-install-prefix)
  (string-append %source-install-prefix "/" (%lisp-type)))

(define %system-install-prefix
  (string-append %source-install-prefix "/systems"))

(define (main-system-name output)
  (let* ((full-name (strip-store-file-name output))
         (lisp-prefix (string-append (%lisp-type) "-"))
         (package-name (if (string-prefix? lisp-prefix full-name)
                           (string-drop full-name (string-length lisp-prefix))
                           full-name)))
    (package-name->name+version package-name)))

(define (lisp-source-directory output name)
  (string-append output (%lisp-source-install-prefix) "/" name))

(define (source-directory output name)
  (string-append output %source-install-prefix "/source/" name))

(define (library-directory output)
  (string-append output %object-prefix
                 "/" (%lisp-type)))

(define (output-translation source-path
                            object-output)
  "Return a translation for the system's source path
to it's binary output."
  `((,source-path
     :**/ :*.*.*)
    (,(library-directory object-output)
     :**/ :*.*.*)))

(define (source-asd-file output name asd-file)
  (string-append (lisp-source-directory output name) "/" asd-file))

(define (find-asd-files output name asd-files)
  (if (null? asd-files)
      (find-files (lisp-source-directory output name) "\\.asd$")
      (map (lambda (asd-file)
             (source-asd-file output name asd-file))
           asd-files)))

(define (copy-files-to-output out name)
  "Copy all files from the current directory to OUT.  Create an extra link to
any system-defining files in the source to a convenient location.  This is
done before any compiling so that the compiled source locations will be
valid."
  (let ((source (getcwd))
        (target (source-directory out name))
        (system-path (string-append out %system-install-prefix)))
    ;; SBCL keeps the modification time of the source file in the compiled
    ;; file, and the source files might just have been patched by a custom
    ;; phase. Therefore we reset the modification time of all the source
    ;; files before compiling.
    (for-each (lambda (file)
                (let ((s (lstat file)))
                  (unless (or (eq? (stat:type s) 'symlink)
                              (not (access? file W_OK)))
                    (utime file 0 0 0 0))))
              (find-files source #:directories? #t))
    (copy-recursively source target #:keep-mtime? #t)
    (mkdir-p system-path)
    (for-each
     (lambda (file)
       (symlink file
                (string-append system-path "/" (basename file))))
     (find-files target "\\.asd$"))
    #t))

(define* (install #:key inputs outputs #:allow-other-keys)
  "Copy and symlink all the source files.
The source files are taken from the corresponding compile package (e.g. SBCL)
if it's present in the native-inputs."
  (define output (assoc-ref outputs "out"))
  (define package-name
    (package-name->name+version
     (strip-store-file-name output)))
  (define (no-prefix pkgname)
    (let ((index (string-index pkgname #\-)))
      (if index
          (string-drop pkgname (1+ index))
          pkgname)))
  (define parent
    (match (assoc package-name inputs
                  (lambda (key alist-car)
                    (let* ((alt-key (no-prefix key))
                           (alist-car (no-prefix alist-car)))
                      (or (string=? alist-car key)
                          (string=? alist-car alt-key)))))
      (#f #f)
      (p (cdr p))))
  (define parent-name
    (and parent
         (package-name->name+version (strip-store-file-name parent))))
  (define parent-source
    (and parent
         (string-append parent "/share/common-lisp/"
                        (let ((index (string-index parent-name #\-)))
                          (if index
                              (string-take parent-name index)
                              parent-name)))))

  (define (first-subdirectory directory) ; From gnu-build-system.
    "Return the file name of the first sub-directory of DIRECTORY."
    (match (scandir directory
                    (lambda (file)
                      (and (not (member file '("." "..")))
                           (file-is-directory? (string-append directory "/"
                                                              file)))))
      ((first . _) first)))
  (define source-directory
    (if (and parent-source
             (file-exists? parent-source))
        (string-append parent-source "/" (first-subdirectory parent-source))
        "."))

  (with-directory-excursion source-directory
    (copy-files-to-output output package-name)))

(define* (copy-source #:key outputs asd-systems #:allow-other-keys)
  "Copy the source to the library output."
  (let* ((out (library-output outputs))
         (install-path (string-append out %source-install-prefix))
         (system-name (main-system-name out)))
    (copy-files-to-output out system-name)
    ;; Hide the files from asdf
    (with-directory-excursion install-path
      (rename-file "source" (%lisp-type))
      (delete-file-recursively "systems")))
  #t)

(define* (configure #:key inputs #:allow-other-keys)
  ;; Create a directory having the configuration files for
  ;; all the dependencies in 'etc/common-lisp/'.
  (let ((out (string-append (getcwd) "/.cl-union")))
    (match inputs
      (((name . directories) ...)
       (union-build out (filter directory-exists? directories)
                    #:create-all-directories? #t
                    #:log-port (%make-void-port "w"))))
    (setenv "CL_UNION" out)
    (setenv "XDG_CONFIG_DIRS" (string-append out "/etc")))
  #t)

(define* (build #:key outputs inputs asd-files asd-systems
                #:allow-other-keys)
  "Compile the system."
  (let* ((out (library-output outputs))
         (system-name (main-system-name out))
         (source-path (string-append out (%lisp-source-install-prefix)))
         (translations (wrap-output-translations
                        `(,(output-translation source-path
                                               out))))
         (asd-files (find-asd-files out system-name asd-files)))
    (setenv "ASDF_OUTPUT_TRANSLATIONS"
            (replace-escaped-macros (format #f "~S" translations)))
    (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
    (compile-systems asd-systems asd-files))
  #t)

(define* (check #:key tests? outputs inputs asd-files asd-systems
                test-asd-file
                #:allow-other-keys)
  "Test the system."
  (let* ((out (library-output outputs))
         (system-name (main-system-name out))
         (asd-files (find-asd-files out system-name asd-files))
         (test-asd-file
          (and=> test-asd-file
                 (cut source-asd-file out system-name <>))))
    (if tests?
        (test-system (first asd-systems) asd-files test-asd-file)
        (format #t "test suite not run~%")))
  #t)

(define* (create-asdf-configuration #:key inputs outputs #:allow-other-keys)
  "Create the ASDF configuration files for the built systems."
  (let* ((system-name (main-system-name (assoc-ref outputs "out")))
         (out (library-output outputs))
         (conf-dir (string-append out "/etc/common-lisp"))
         (deps-conf-dir (string-append (getenv "CL_UNION") "/etc/common-lisp"))
         (source-dir (lisp-source-directory out system-name))
         (lib-dir (string-append (library-directory out) "/" system-name)))
    (make-asdf-configuration system-name conf-dir deps-conf-dir
                             source-dir lib-dir)
    #t))

(define* (cleanup-files #:key outputs
                        #:allow-other-keys)
  "Remove any compiled files which are not a part of the final bundle."
  (let* ((out (library-output outputs))
         (cache-directory (string-append out "/.cache")))
    ;; Remove the cache directory in case the lisp implementation wrote
    ;; something in there when compiling or testing a system.
    (when (directory-exists? cache-directory)
      (delete-file-recursively cache-directory)))
  #t)

(define* (strip #:rest args)
  ;; stripping sbcl binaries removes their entry program and extra systems
  (or (string=? (%lisp-type) "sbcl")
      (apply (assoc-ref gnu:%standard-phases 'strip) args)))

(define %standard-phases/source
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'check)
    (delete 'build)
    (replace 'install install)))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (replace 'configure configure)
    (add-before 'configure 'copy-source copy-source)
    (replace 'build build)
    (replace 'check check)
    (add-after 'check 'create-asdf-configuration create-asdf-configuration)
    (add-after 'create-asdf-configuration 'cleanup cleanup-files)
    (delete 'install)
    (replace 'strip strip)))

(define* (asdf-build #:key inputs
                     (phases %standard-phases)
                     #:allow-other-keys
                     #:rest args)
  (apply gnu:gnu-build
         #:inputs inputs
         #:phases phases
         args))

(define* (asdf-build/source #:key inputs
                            (phases %standard-phases/source)
                            #:allow-other-keys
                            #:rest args)
  (apply gnu:gnu-build
         #:inputs inputs
         #:phases phases
         args))

;;; asdf-build-system.scm ends here

debug log:

solving 5a4fc44aef ...
found 5a4fc44aef in https://yhetil.org/guix-bugs/8735v0b53e.fsf@yamatai/
found 6ad855cab2 in https://git.savannah.gnu.org/cgit/guix.git
preparing index
index prepared:
100644 6ad855cab2d20f1e89f8a7649fb6bf2447155b85	guix/build/asdf-build-system.scm

applying [1/1] https://yhetil.org/guix-bugs/8735v0b53e.fsf@yamatai/
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 6ad855cab2..5a4fc44aef 100644

Checking patch guix/build/asdf-build-system.scm...
Applied patch guix/build/asdf-build-system.scm cleanly.

index at:
100644 5a4fc44aef86b930a7d990defd578d397784330c	guix/build/asdf-build-system.scm

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).