guix/build-system/guile.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   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 guile)
  20   #:use-module (guix store)
  21   #:use-module (guix utils)
  22   #:use-module (guix packages)
  23   #:use-module (guix derivations)
  24   #:use-module (guix search-paths)
  25   #:use-module (guix build-system)
  26   #:use-module (guix build-system gnu)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-26)
  29   #:export (%guile-build-system-modules
  30             guile-build-system))
  31
  32 (define %scheme-file-regexp
  33   ;; Regexp to match Scheme files.
  34   "\\.(scm|sls)$")
  35
  36 (define %guile-build-system-modules
  37   ;; Build-side modules imported by default.
  38   `((guix build guile-build-system)
  39     ,@%gnu-build-system-modules))
  40
  41 (define* (lower name
  42                 #:key source inputs native-inputs outputs system target
  43                 (implicit-inputs? #t)
  44                 #:allow-other-keys
  45                 #:rest arguments)
  46   "Return a bag for NAME."
  47
  48   ;; Note: There's no #:guile argument (unlike, for instance,
  49   ;; 'ocaml-build-system' which has #:ocaml.)  This is so we can keep
  50   ;; procedures like 'package-for-guile-2.0' unchanged and simple.
  51
  52   (define private-keywords
  53     '(#:target #:inputs #:native-inputs
  54       #:implicit-inputs?))
  55
  56   (bag
  57     (name name)
  58     (system system) (target target)
  59     (host-inputs `(
  60                    ,@inputs))
  61     (build-inputs `(,@(if source
  62                           `(("source" ,source))
  63                           '())
  64                     ,@native-inputs
  65                     ,@(if implicit-inputs?
  66                           (map (cute assoc <> (standard-packages))
  67                                '("tar" "gzip" "bzip2" "xz" "locales"))
  68                           '())))
  69     (outputs outputs)
  70     (build (if target guile-cross-build guile-build))
  71     (arguments (strip-keyword-arguments private-keywords arguments))))
  72
  73 (define %compile-flags
  74   ;; Flags passed to 'guild compile' by default.  We choose a common
  75   ;; denominator between Guile 2.0 and 2.2.
  76   ''("-Wunbound-variable" "-Warity-mismatch" "-Wformat"))
  77
  78 (define* (guile-build store name inputs
  79                       #:key source
  80                       (guile #f)
  81                       (phases '%standard-phases)
  82                       (outputs '("out"))
  83                       (search-paths '())
  84                       (system (%current-system))
  85                       (source-directory ".")
  86                       not-compiled-file-regexp
  87                       (scheme-file-regexp %scheme-file-regexp)
  88                       (compile-flags %compile-flags)
  89                       (imported-modules %guile-build-system-modules)
  90                       (modules '((guix build guile-build-system)
  91                                  (guix build utils))))
  92   "Build SOURCE using Guile taken from the native inputs, and with INPUTS."
  93   (define builder
  94     `(begin
  95        (use-modules ,@modules)
  96        (guile-build #:name ,name
  97                     #:source ,(match (assoc-ref inputs "source")
  98                                 (((? derivation? source))
  99                                  (derivation->output-path source))
 100                                 ((source)
 101                                  source)
 102                                 (source
 103                                  source))
 104                     #:source-directory ,source-directory
 105                     #:scheme-file-regexp ,scheme-file-regexp
 106                     #:not-compiled-file-regexp ,not-compiled-file-regexp
 107                     #:compile-flags ,compile-flags
 108                     #:phases ,phases
 109                     #:system ,system
 110                     #:outputs %outputs
 111                     #:search-paths ',(map search-path-specification->sexp
 112                                           search-paths)
 113                     #:inputs %build-inputs)))
 114
 115   (define guile-for-build
 116     (match guile
 117       ((? package?)
 118        (package-derivation store guile system #:graft? #f))
 119       (#f                                         ; the default
 120        (let* ((distro (resolve-interface '(gnu packages commencement)))
 121               (guile  (module-ref distro 'guile-final)))
 122          (package-derivation store guile system #:graft? #f)))))
 123
 124   (build-expression->derivation store name builder
 125                                 #:inputs inputs
 126                                 #:system system
 127                                 #:modules imported-modules
 128                                 #:outputs outputs
 129                                 #:guile-for-build guile-for-build))
 130
 131 (define* (guile-cross-build store name
 132                             #:key
 133                             (system (%current-system)) target
 134                             native-drvs target-drvs
 135                             (guile #f)
 136                             source
 137                             (outputs '("out"))
 138                             (search-paths '())
 139                             (native-search-paths '())
 140
 141                             (phases '%standard-phases)
 142                             (source-directory ".")
 143                             not-compiled-file-regexp
 144                             (compile-flags %compile-flags)
 145                             (imported-modules %guile-build-system-modules)
 146                             (modules '((guix build guile-build-system)
 147                                        (guix build utils))))
 148   (define builder
 149     `(begin
 150        (use-modules ,@modules)
 151
 152        (let ()
 153          (define %build-host-inputs
 154            ',(map (match-lambda
 155                     ((name (? derivation? drv) sub ...)
 156                      `(,name . ,(apply derivation->output-path drv sub)))
 157                     ((name path)
 158                      `(,name . ,path)))
 159                   native-drvs))
 160
 161          (define %build-target-inputs
 162            ',(map (match-lambda
 163                     ((name (? derivation? drv) sub ...)
 164                      `(,name . ,(apply derivation->output-path drv sub)))
 165                     ((name (? package? pkg) sub ...)
 166                      (let ((drv (package-cross-derivation store pkg
 167                                                           target system)))
 168                        `(,name . ,(apply derivation->output-path drv sub))))
 169                     ((name path)
 170                      `(,name . ,path)))
 171                   target-drvs))
 172
 173          (guile-build #:source ,(match (assoc-ref native-drvs "source")
 174                                   (((? derivation? source))
 175                                    (derivation->output-path source))
 176                                   ((source)
 177                                    source)
 178                                   (source
 179                                    source))
 180                       #:system ,system
 181                       #:target ,target
 182                       #:outputs %outputs
 183                       #:source-directory ,source-directory
 184                       #:not-compiled-file-regexp ,not-compiled-file-regexp
 185                       #:compile-flags ,compile-flags
 186                       #:inputs %build-target-inputs
 187                       #:native-inputs %build-host-inputs
 188                       #:search-paths ',(map search-path-specification->sexp
 189                                             search-paths)
 190                       #:native-search-paths ',(map
 191                                                search-path-specification->sexp
 192                                                native-search-paths)
 193                       #:phases ,phases))))
 194
 195   (define guile-for-build
 196     (match guile
 197       ((? package?)
 198        (package-derivation store guile system #:graft? #f))
 199       (#f                                         ; the default
 200        (let* ((distro (resolve-interface '(gnu packages commencement)))
 201               (guile  (module-ref distro 'guile-final)))
 202          (package-derivation store guile system #:graft? #f)))))
 203
 204   (build-expression->derivation store name builder
 205                                 #:system system
 206                                 #:inputs (append native-drvs target-drvs)
 207                                 #:outputs outputs
 208                                 #:modules imported-modules
 209                                 #:substitutable? substitutable?
 210                                 #:guile-for-build guile-for-build))
 211
 212 (define guile-build-system
 213   (build-system
 214     (name 'guile)
 215     (description "The build system for simple Guile packages")
 216     (lower lower)))