guix/build-system/asdf.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
   3 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix build-system asdf)
  21   #:use-module (guix store)
  22   #:use-module (guix utils)
  23   #:use-module (guix memoization)
  24   #:use-module (guix packages)
  25   #:use-module (guix derivations)
  26   #:use-module (guix search-paths)
  27   #:use-module ((guix build utils)
  28                 #:select ((package-name->name+version
  29                            . hyphen-separated-name->name+version)))
  30   #:use-module (guix build-system)
  31   #:use-module (guix build-system gnu)
  32   #:use-module (ice-9 match)
  33   #:use-module (ice-9 regex)
  34   #:use-module (srfi srfi-1)
  35   #:use-module (srfi srfi-26)
  36   #:use-module (gnu packages)
  37   #:export (%asdf-build-system-modules
  38             %asdf-build-modules
  39             asdf-build
  40             asdf-build-system/sbcl
  41             asdf-build-system/ecl
  42             asdf-build-system/source
  43             sbcl-package->cl-source-package
  44             sbcl-package->ecl-package))
  45
  46 ;; Commentary:
  47 ;;
  48 ;; Standard build procedure for asdf packages.  This is implemented as an
  49 ;; extension of 'gnu-build-system'.
  50 ;;
  51 ;; Code:
  52
  53 (define %asdf-build-system-modules
  54   ;; Imported build-side modules
  55   `((guix build asdf-build-system)
  56     (guix build lisp-utils)
  57     ,@%gnu-build-system-modules))
  58
  59 (define %asdf-build-modules
  60   ;; Used (visible) build-side modules
  61   '((guix build asdf-build-system)
  62     (guix build utils)
  63     (guix build lisp-utils)))
  64
  65 (define (default-lisp implementation)
  66   "Return the default package for the lisp IMPLEMENTATION."
  67   ;; Lazily resolve the binding to avoid a circular dependency.
  68   (let ((lisp-module (resolve-interface '(gnu packages lisp))))
  69     (module-ref lisp-module implementation)))
  70
  71 (define* (lower/source name
  72                        #:key source inputs outputs native-inputs system target
  73                        #:allow-other-keys
  74                        #:rest arguments)
  75   "Return a bag for NAME"
  76   (define private-keywords
  77     '(#:target #:inputs #:native-inputs))
  78
  79   (and (not target)
  80        (bag
  81          (name name)
  82          (system system)
  83          (host-inputs `(,@(if source
  84                               `(("source" ,source))
  85                               '())
  86                         ,@inputs
  87                         ,@(standard-packages)))
  88          (build-inputs native-inputs)
  89          (outputs outputs)
  90          (build asdf-build/source)
  91          (arguments (strip-keyword-arguments private-keywords arguments)))))
  92
  93 (define* (asdf-build/source store name inputs
  94                             #:key source outputs
  95                             (phases '(@ (guix build asdf-build-system)
  96                                         %standard-phases/source))
  97                             (search-paths '())
  98                             (system (%current-system))
  99                             (guile #f)
 100                             (imported-modules %asdf-build-system-modules)
 101                             (modules %asdf-build-modules))
 102   (define builder
 103     `(begin
 104        (use-modules ,@modules)
 105        (asdf-build/source #:name ,name
 106                           #:source ,(match (assoc-ref inputs "source")
 107                                       (((? derivation? source))
 108                                        (derivation->output-path source))
 109                                       ((source) source)
 110                                       (source source))
 111                           #:system ,system
 112                           #:phases ,phases
 113                           #:outputs %outputs
 114                           #:search-paths ',(map search-path-specification->sexp
 115                                                 search-paths)
 116                           #:inputs %build-inputs)))
 117
 118   (define guile-for-build
 119     (match guile
 120       ((? package?)
 121        (package-derivation store guile system #:graft? #f))
 122       (#f
 123        (let* ((distro (resolve-interface '(gnu packages commencement)))
 124               (guile (module-ref distro 'guile-final)))
 125          (package-derivation store guile system #:graft? #f)))))
 126
 127   (build-expression->derivation store name builder
 128                                 #:inputs inputs
 129                                 #:system system
 130                                 #:modules imported-modules
 131                                 #:outputs outputs
 132                                 #:guile-for-build guile-for-build))
 133
 134 (define* (package-with-build-system from-build-system to-build-system
 135                                     from-prefix to-prefix
 136                                     #:key variant-property
 137                                     phases-transformer)
 138   "Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM,
 139 and returns one using TO-BUILD-SYSTEM.  If PKG was prefixed by FROM-PREFIX,
 140 the resulting package will be prefixed by TO-PREFIX.  Inputs of PKG are
 141 recursively transformed using the same rule.  The result's #:phases argument
 142 will be modified by PHASES-TRANSFORMER, an S-expression which evaluates on the
 143 build side to a procedure of one argument.
 144
 145 VARIANT-PROPERTY can be added to a package's properties to indicate that the
 146 corresponding package promise should be used as the result of this
 147 transformation.  This allows the result to differ from what the transformation
 148 would otherwise produce.
 149
 150 If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package will be
 151 set up using CL source package conventions."
 152   (define target-is-source? (eq? asdf-build-system/source to-build-system))
 153
 154   (define (transform-package-name name)
 155     (if (string-prefix? from-prefix name)
 156         (let ((new-name (string-drop name (string-length from-prefix))))
 157           (if (string-prefix? to-prefix new-name)
 158               new-name
 159               (string-append to-prefix new-name)))
 160         name))
 161
 162   (define (has-from-build-system? pkg)
 163     (eq? from-build-system (package-build-system pkg)))
 164
 165   (define (find-input-package pkg)
 166     (let* ((name (package-name pkg))
 167            (new-name (transform-package-name name))
 168            (pkgs (find-packages-by-name new-name)))
 169       (if (null? pkgs) #f (list-ref pkgs 0))))
 170
 171   (define transform
 172     (mlambda (pkg)
 173       (define rewrite
 174         (match-lambda
 175           ((name content . rest)
 176            (let* ((is-package? (package? content))
 177                   (new-content (if is-package?
 178                                    (or (find-input-package content)
 179                                        (transform content))
 180                                    content)))
 181              `(,name ,new-content ,@rest)))))
 182
 183       ;; Special considerations for source packages: CL inputs become
 184       ;; propagated, and un-handled arguments are removed.
 185
 186       (define (new-propagated-inputs)
 187         (if target-is-source?
 188             (map rewrite
 189                  (append
 190                   (filter (match-lambda
 191                             ((_ input . _)
 192                              (has-from-build-system? input)))
 193                           (append (package-inputs pkg)
 194                                   ;; The native inputs might be needed just
 195                                   ;; to load the system.
 196                                   (package-native-inputs pkg)))
 197                   (package-propagated-inputs pkg)))
 198
 199             (map rewrite (package-propagated-inputs pkg))))
 200
 201       (define (new-inputs inputs-getter)
 202         (if target-is-source?
 203             (map rewrite
 204                  (filter (match-lambda
 205                            ((_ input . _)
 206                             (not (has-from-build-system? input))))
 207                          (inputs-getter pkg)))
 208             (map rewrite (inputs-getter pkg))))
 209
 210       (define base-arguments
 211         (if target-is-source?
 212             (strip-keyword-arguments
 213              '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file)
 214              (package-arguments pkg))
 215             (package-arguments pkg)))
 216
 217       (cond
 218        ((and variant-property
 219              (assoc-ref (package-properties pkg) variant-property))
 220         => force)
 221
 222        ((has-from-build-system? pkg)
 223         (package
 224           (inherit pkg)
 225           (location (package-location pkg))
 226           (name (transform-package-name (package-name pkg)))
 227           (build-system to-build-system)
 228           (arguments
 229            (substitute-keyword-arguments base-arguments
 230              ((#:phases phases) (list phases-transformer phases))))
 231           (inputs (new-inputs package-inputs))
 232           (propagated-inputs (new-propagated-inputs))
 233           (native-inputs (append (if target-is-source?
 234                                      (list (list (package-name pkg) pkg))
 235                                      '())
 236                                  (new-inputs package-native-inputs)))
 237           (outputs (if target-is-source?
 238                        '("out")
 239                        (package-outputs pkg)))))
 240        (else pkg))))
 241
 242   transform)
 243
 244 (define (strip-variant-as-necessary variant pkg)
 245   (define properties (package-properties pkg))
 246   (if (assoc variant properties)
 247       (package
 248         (inherit pkg)
 249         (properties (alist-delete variant properties)))
 250       pkg))
 251
 252 (define (lower lisp-type)
 253   (lambda* (name
 254             #:key source inputs outputs native-inputs system target
 255             (lisp (default-lisp (string->symbol lisp-type)))
 256             #:allow-other-keys
 257             #:rest arguments)
 258     "Return a bag for NAME"
 259     (define private-keywords
 260       '(#:target #:inputs #:native-inputs #:lisp))
 261
 262     (and (not target)
 263          (bag
 264            (name name)
 265            (system system)
 266            (host-inputs `(,@(if source
 267                                 `(("source" ,source))
 268                                 '())
 269                           ,@inputs
 270                           ,@(standard-packages)))
 271            (build-inputs `((,lisp-type ,lisp)
 272                            ,@native-inputs))
 273            (outputs outputs)
 274            (build (asdf-build lisp-type))
 275            (arguments (strip-keyword-arguments private-keywords arguments))))))
 276
 277 (define (asdf-build lisp-type)
 278   (lambda* (store name inputs
 279                   #:key source outputs
 280                   (tests? #t)
 281                   (asd-file #f)
 282                   (asd-system-name #f)
 283                   (test-asd-file #f)
 284                   (phases '(@ (guix build asdf-build-system)
 285                               %standard-phases))
 286                   (search-paths '())
 287                   (system (%current-system))
 288                   (guile #f)
 289                   (imported-modules %asdf-build-system-modules)
 290                   (modules %asdf-build-modules))
 291
 292     (define system-name
 293       (or asd-system-name
 294           (string-drop
 295            ;; NAME is the value returned from `package-full-name'.
 296            (hyphen-separated-name->name+version name)
 297            (1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix.
 298
 299     (define builder
 300       `(begin
 301          (use-modules ,@modules)
 302          (parameterize ((%lisp (string-append
 303                                 (assoc-ref %build-inputs ,lisp-type)
 304                                 "/bin/" ,lisp-type))
 305                         (%lisp-type ,lisp-type))
 306            (asdf-build #:name ,name
 307                        #:source ,(match (assoc-ref inputs "source")
 308                                    (((? derivation? source))
 309                                     (derivation->output-path source))
 310                                    ((source) source)
 311                                    (source source))
 312                        #:asd-file ,(or asd-file (string-append system-name ".asd"))
 313                        #:asd-system-name ,system-name
 314                        #:test-asd-file ,test-asd-file
 315                        #:system ,system
 316                        #:tests? ,tests?
 317                        #:phases ,phases
 318                        #:outputs %outputs
 319                        #:search-paths ',(map search-path-specification->sexp
 320                                              search-paths)
 321                        #:inputs %build-inputs))))
 322
 323     (define guile-for-build
 324       (match guile
 325         ((? package?)
 326          (package-derivation store guile system #:graft? #f))
 327         (#f
 328          (let* ((distro (resolve-interface '(gnu packages commencement)))
 329                 (guile (module-ref distro 'guile-final)))
 330            (package-derivation store guile system #:graft? #f)))))
 331
 332     (build-expression->derivation store name builder
 333                                   #:inputs inputs
 334                                   #:system system
 335                                   #:modules imported-modules
 336                                   #:outputs outputs
 337                                   #:guile-for-build guile-for-build)))
 338
 339 (define asdf-build-system/sbcl
 340   (build-system
 341     (name 'asdf/sbcl)
 342     (description "The build system for ASDF binary packages using SBCL")
 343     (lower (lower "sbcl"))))
 344
 345 (define asdf-build-system/ecl
 346   (build-system
 347     (name 'asdf/ecl)
 348     (description "The build system for ASDF binary packages using ECL")
 349     (lower (lower "ecl"))))
 350
 351 (define asdf-build-system/source
 352   (build-system
 353     (name 'asdf/source)
 354     (description "The build system for ASDF source packages")
 355     (lower lower/source)))
 356
 357 (define sbcl-package->cl-source-package
 358   (let* ((property 'cl-source-variant)
 359          (transformer
 360           (package-with-build-system asdf-build-system/sbcl
 361                                      asdf-build-system/source
 362                                      "sbcl-"
 363                                      "cl-"
 364                                      #:variant-property property
 365                                      #:phases-transformer
 366                                      '(const %standard-phases/source))))
 367     (lambda (pkg)
 368       (transformer
 369        (strip-variant-as-necessary property pkg)))))
 370
 371 (define sbcl-package->ecl-package
 372   (let* ((property 'ecl-variant)
 373          (transformer
 374           (package-with-build-system asdf-build-system/sbcl
 375                                      asdf-build-system/ecl
 376                                      "sbcl-"
 377                                      "ecl-"
 378                                      #:variant-property property
 379                                      #:phases-transformer
 380                                      'identity)))
 381     (lambda (pkg)
 382       (transformer
 383        (strip-variant-as-necessary property pkg)))))
 384
 385 ;;; asdf.scm ends here