guix/build/guile-build-system.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 guile-build-system)
  20   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  21   #:use-module (guix build utils)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-26)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 popen)
  26   #:use-module (ice-9 rdelim)
  27   #:use-module (ice-9 regex)
  28   #:use-module (ice-9 format)
  29   #:use-module (guix build utils)
  30   #:export (target-guile-effective-version
  31             %standard-phases
  32             guile-build))
  33
  34 (define* (target-guile-effective-version #:optional guile)
  35   "Return the effective version of GUILE or whichever 'guile' is in $PATH.
  36 Return #false if it cannot be determined."
  37   (let* ((pipe (open-pipe* OPEN_READ
  38                            (if guile
  39                                (string-append guile "/bin/guile")
  40                                "guile")
  41                            "-c" "(display (effective-version))"))
  42          (line (read-line pipe)))
  43     (and (zero? (close-pipe pipe))
  44          (string? line)
  45          line)))
  46
  47 (define (file-sans-extension file)                ;TODO: factorize
  48   "Return the substring of FILE without its extension, if any."
  49   (let ((dot (string-rindex file #\.)))
  50     (if dot
  51         (substring file 0 dot)
  52         file)))
  53
  54 (define %scheme-file-regexp
  55   ;; Regexp to match Scheme files.
  56   "\\.(scm|sls)$")
  57
  58 (define %documentation-file-regexp
  59   ;; Regexp to match README files and the likes.
  60   "^(README.*|.*\\.html|.*\\.org|.*\\.md)$")
  61
  62 (define* (set-locale-path #:key inputs native-inputs
  63                           #:allow-other-keys)
  64   "Set 'GUIX_LOCPATH'."
  65   (match (assoc-ref (or native-inputs inputs) "locales")
  66     (#f #t)
  67     (locales
  68      (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))
  69      #t)))
  70
  71 (define* (invoke-each commands
  72                       #:key (max-processes (current-processor-count))
  73                       report-progress)
  74   "Run each command in COMMANDS in a separate process, using up to
  75 MAX-PROCESSES processes in parallel.  Call REPORT-PROGRESS at each step.
  76 Raise an error if one of the processes exit with non-zero."
  77   (define total
  78     (length commands))
  79
  80   (define processes
  81     (make-hash-table))
  82
  83   (define (wait-for-one-process)
  84     (match (waitpid WAIT_ANY)
  85       ((pid . status)
  86        (let ((command (hashv-ref processes pid)))
  87          (hashv-remove! processes command)
  88          (unless (zero? (status:exit-val status))
  89            (format (current-error-port)
  90                    "process '~{~a ~}' failed with status ~a~%"
  91                    command status)
  92            (exit 1))))))
  93
  94   (define (fork-and-run-command command)
  95     (match (primitive-fork)
  96       (0
  97        (dynamic-wind
  98          (const #t)
  99          (lambda ()
 100            (apply execlp command))
 101          (lambda ()
 102            (primitive-exit 127))))
 103       (pid
 104        (hashv-set! processes pid command)
 105        #t)))
 106
 107   (let loop ((commands  commands)
 108              (running   0)
 109              (completed 0))
 110     (match commands
 111       (()
 112        (or (zero? running)
 113            (let ((running   (- running 1))
 114                  (completed (+ completed 1)))
 115              (wait-for-one-process)
 116              (report-progress total completed)
 117              (loop commands running completed))))
 118       ((command . rest)
 119        (if (< running max-processes)
 120            (let ((running (+ 1 running)))
 121              (fork-and-run-command command)
 122              (loop rest running completed))
 123            (let ((running   (- running 1))
 124                  (completed (+ completed 1)))
 125              (wait-for-one-process)
 126              (report-progress total completed)
 127              (loop commands running completed)))))))
 128
 129 (define* (report-build-progress total completed
 130                                 #:optional (log-port (current-error-port)))
 131   "Report that COMPLETED out of TOTAL files have been completed."
 132   (format log-port "[~2d/~2d] Compiling...~%"
 133           completed total)
 134   (force-output log-port))
 135
 136 (define* (build #:key outputs inputs native-inputs
 137                 (source-directory ".")
 138                 (compile-flags '())
 139                 (scheme-file-regexp %scheme-file-regexp)
 140                 (not-compiled-file-regexp #f)
 141                 target
 142                 #:allow-other-keys)
 143   "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP.  Files
 144 matching NOT-COMPILED-FILE-REGEXP, if true, are not compiled but are
 145 installed; this is useful for files that are meant to be included."
 146   (let* ((out        (assoc-ref outputs "out"))
 147          (guile      (assoc-ref (or native-inputs inputs) "guile"))
 148          (effective  (target-guile-effective-version guile))
 149          (module-dir (string-append out "/share/guile/site/"
 150                                     effective))
 151          (go-dir     (string-append out "/lib/guile/"
 152                                     effective "/site-ccache/"))
 153          (guild      (string-append guile "/bin/guild"))
 154          (flags      (if target
 155                          (cons (string-append "--target=" target)
 156                                compile-flags)
 157                          compile-flags)))
 158     (if target
 159         (format #t "Cross-compiling for '~a' with Guile ~a...~%"
 160                 target effective)
 161         (format #t "Compiling with Guile ~a...~%" effective))
 162     (format #t "compile flags: ~s~%" flags)
 163
 164     ;; Make installation directories.
 165     (mkdir-p module-dir)
 166     (mkdir-p go-dir)
 167
 168     ;; Compile .scm files and install.
 169     (setenv "GUILE_AUTO_COMPILE" "0")
 170     (setenv "GUILE_LOAD_COMPILED_PATH"
 171             (string-append go-dir
 172                            (match (getenv "GUILE_LOAD_COMPILED_PATH")
 173                              (#f "")
 174                              (path (string-append ":" path)))))
 175
 176   (let ((source-files
 177            (with-directory-excursion source-directory
 178              (find-files "." scheme-file-regexp))))
 179     (invoke-each
 180      (filter-map (lambda (file)
 181                    (and (or (not not-compiled-file-regexp)
 182                             (not (string-match not-compiled-file-regexp
 183                                                file)))
 184                         (cons* guild
 185                                "guild" "compile"
 186                                "-L" source-directory
 187                                "-o" (string-append go-dir
 188                                                    (file-sans-extension file)
 189                                                    ".go")
 190                                (string-append source-directory "/" file)
 191                                flags)))
 192                  source-files)
 193      #:max-processes (parallel-job-count)
 194      #:report-progress report-build-progress)
 195
 196     (for-each
 197      (lambda (file)
 198          (install-file (string-append source-directory "/" file)
 199                        (string-append module-dir
 200                                       "/" (dirname file))))
 201      source-files))
 202     #t))
 203
 204 (define* (install-documentation #:key outputs
 205                                 (documentation-file-regexp
 206                                  %documentation-file-regexp)
 207                                 #:allow-other-keys)
 208   "Install files that mactch DOCUMENTATION-FILE-REGEXP."
 209   (let* ((out (assoc-ref outputs "out"))
 210          (doc (string-append out "/share/doc/"
 211                              (strip-store-file-name out))))
 212     (for-each (cut install-file <> doc)
 213               (find-files "." documentation-file-regexp))
 214     #t))
 215
 216 (define %standard-phases
 217   (modify-phases gnu:%standard-phases
 218     (delete 'bootstrap)
 219     (delete 'configure)
 220     (add-before 'install-locale 'set-locale-path
 221       set-locale-path)
 222     (replace 'build build)
 223     (add-after 'build 'install-documentation
 224       install-documentation)
 225     (delete 'check)
 226     (delete 'strip)
 227     (delete 'validate-runpath)
 228     (delete 'install)))
 229
 230 (define* (guile-build #:key (phases %standard-phases)
 231                       #:allow-other-keys #:rest args)
 232   "Build the given Guile package, applying all of PHASES in order."
 233   (apply gnu:gnu-build #:phases phases args))