~ruther/guix-local

40f56176c517d9b5e0d3da8cc06d3ccde6b58cc2 — Andy Patterson 9 years ago 0186a46
build-system/asdf: Handle unusually-named systems.

* guix/build/lisp-utils.scm (valid-char-set): New variable.
(normalize-string): New procedure.
(compiled-system): Truncate the name of a system which contains slashes.
(generate-system-definition, make-asd-file): Use `normalize-string' to alter
the names of the created system and its dependencies.
* guix/build/asdf-build-system.scm (create-asd-file): Normalize the name of
the asd file being created.
2 files changed, 28 insertions(+), 14 deletions(-)

M guix/build/asdf-build-system.scm
M guix/build/lisp-utils.scm
M guix/build/asdf-build-system.scm => guix/build/asdf-build-system.scm +4 -2
@@ 153,8 153,10 @@ valid."
  (let*-values (((out) (library-output outputs))
                ((_ version) (package-name->name+version
                              (strip-store-file-name out)))
                ((new-asd-file) (string-append (library-directory out)
                                               "/" asd-system-name ".asd")))
                ((new-asd-file) (string-append
                                 (library-directory out)
                                 "/" (normalize-string asd-system-name)
                                 ".asd")))

    (make-asd-file new-asd-file
                   #:system asd-system-name

M guix/build/lisp-utils.scm => guix/build/lisp-utils.scm +24 -12
@@ 40,7 40,9 @@
            prepend-to-source-registry
            build-program
            build-image
            make-asd-file))
            make-asd-file
            valid-char-set
            normalize-string))

;;; Commentary:
;;;


@@ 65,6 67,15 @@
(define (%bundle-install-prefix)
  (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))

;; See nix/libstore/store-api.cc#checkStoreName.
(define valid-char-set
  (string->char-set
   "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))

(define (normalize-string str)
  "Replace invalid characters in STR with a hyphen."
  (string-join (string-tokenize str valid-char-set) "-"))

(define (inputs->asd-file-map inputs)
  "Produce a hash table of the form (system . asd-file), where system is the
name of an ASD system, and asd-file is the full path to its definition."


@@ 161,14 172,15 @@ asdf:system-depends-on.  First load the system's ASD-FILE."
        (delete-file deps-file)))))

(define (compiled-system system)
  (match (%lisp-type)
    ("sbcl" (string-append system "--system"))
    (_ system)))
  (let ((system (basename system))) ; this is how asdf handles slashes
    (match (%lisp-type)
      ("sbcl" (string-append system "--system"))
      (_ system))))

(define* (generate-system-definition system
                                     #:key version dependencies)
  `(asdf:defsystem
    ,system
    ,(normalize-string system)
    :class asdf/bundle:prebuilt-system
    :version ,version
    :depends-on ,dependencies


@@ 261,20 273,20 @@ to locate its dependent systems."
  "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
  (define dependencies
    (system-dependencies system system-asd-file))
    (let ((deps
           (system-dependencies system system-asd-file)))
      (if (eq? 'NIL deps)
          '()
          (map normalize-string deps))))

  (define lisp-input-map
    (inputs->asd-file-map inputs))

  (define registry
    (filter-map hash-get-handle
                (make-list (if (eq? 'NIL dependencies)
                               0
                               (length dependencies))
                (make-list (length dependencies)
                           lisp-input-map)
                (if (eq? 'NIL dependencies)
                    '()
                    dependencies)))
                dependencies))

  (call-with-output-file asd-file
    (lambda (port)