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