code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build gremlin)
  #:use-module (guix elf)
  #:use-module ((guix build utils) #:select (store-file-name?))
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:export (elf-error?
            elf-error-elf
            invalid-segment-size?
            invalid-segment-size-segment

            elf-dynamic-info
            elf-dynamic-info?
            elf-dynamic-info-soname
            elf-dynamic-info-needed
            elf-dynamic-info-rpath
            elf-dynamic-info-runpath
            expand-origin

            validate-needed-in-runpath
            strip-runpath))

;;; Commentary:
;;;
;;; A gremlin is sort-of like an elf, you know, and this module provides tools
;;; to deal with dynamic-link information from ELF files.
;;;
;;; Code:

(define-condition-type &elf-error &error
  elf-error?
  (elf elf-error-elf))

(define-condition-type &invalid-segment-size &elf-error
  invalid-segment-size?
  (segment invalid-segment-size-segment))

(define (dynamic-link-segment elf)
  "Return the 'PT_DYNAMIC' segment of ELF--i.e., the segment that contains
dynamic linking information."
  (let ((size (bytevector-length (elf-bytes elf))))
    (find (lambda (segment)
            (unless (<= (+ (elf-segment-offset segment)
                           (elf-segment-filesz segment))
                        size)
              ;; This happens on separate debug output files created by
              ;; 'strip --only-keep-debug' (Binutils 2.25.)
              (raise (condition (&invalid-segment-size
                                 (elf elf)
                                 (segment segment)))))

            (= (elf-segment-type segment) PT_DYNAMIC))
          (elf-segments elf))))

(define (word-reader size byte-order)
  "Return a procedure to read a word of SIZE bytes according to BYTE-ORDER."
  (case size
    ((8)
     (lambda (bv index)
       (bytevector-u64-ref bv index byte-order)))
    ((4)
     (lambda (bv index)
       (bytevector-u32-ref bv index byte-order)))))

;; Dynamic entry:
;;
;; typedef struct
;; {
;;   Elf64_Sxword       d_tag;   /* Dynamic entry type */
;;   union
;;     {
;;       Elf64_Xword d_val;      /* Integer value */
;;       Elf64_Addr d_ptr;       /* Address value */
;;     } d_un;
;; } Elf64_Dyn;

(define-record-type <dynamic-entry>
  (dynamic-entry type value offset)
  dynamic-entry?
  (type   dynamic-entry-type)                     ;DT_*
  (value  dynamic-entry-value)                    ;string | number | ...
  (offset dynamic-entry-offset))                  ;integer

(define (raw-dynamic-entries elf segment)
  "Return as a list of <dynamic-entry> for the dynamic entries found in
SEGMENT, the 'PT_DYNAMIC' segment of ELF."
  (define start
    (elf-segment-offset segment))
  (define bytes
    (elf-bytes elf))
  (define word-size
    (elf-word-size elf))
  (define byte-order
    (elf-byte-order elf))
  (define read-word
    (word-reader word-size byte-order))

  (let loop ((offset 0)
             (result '()))
    (if (>= offset (elf-segment-memsz segment))
        (reverse result)
        (let ((type  (read-word bytes (+ start offset)))
              (value (read-word bytes (+ start offset word-size))))
          (if (= type DT_NULL)                    ;finished?
              (reverse result)
              (loop (+ offset (* 2 word-size))
                    (cons (dynamic-entry type value
                                         (+ start offset word-size))
                          result)))))))

(define (vma->offset elf vma)
  "Convert VMA, a virtual memory address, to an offset within ELF.

Do that by looking at the loadable program segment (PT_LOAD) of ELF that
contains VMA and by taking into account that segment's virtual address and
offset."
  ;; See 'offset_from_vma' in Binutils.
  (define loads
    (filter (lambda (segment)
              (= (elf-segment-type segment) PT_LOAD))
            (elf-segments elf)))

  (let ((load (find (lambda (segment)
                      (let ((vaddr (elf-segment-vaddr segment)))
                        (and (>= vma vaddr)
                             (< vma (+ (elf-segment-memsz segment)
                                       vaddr)))))
                    loads)))
    (+ (- vma (elf-segment-vaddr load))
       (elf-segment-offset load))))

(define (dynamic-entries elf segment)
  "Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment
of ELF, as a list of <dynamic-entry>.  The value of each entry may be a string
or an integer depending on the entry type (for instance, the value of
DT_NEEDED entries is a string.)  Likewise the offset is the offset within the
string table if the type is a string."
  (define entries
    (raw-dynamic-entries elf segment))

  (define string-table-offset
    (any (lambda (entry)
           (and (= (dynamic-entry-type entry) DT_STRTAB)
                (dynamic-entry-value entry)))
         entries))

  (define (interpret-dynamic-entry entry)
    (let ((type  (dynamic-entry-type entry))
          (value (dynamic-entry-value entry)))
      (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
             (if string-table-offset
                 (let* ((offset (vma->offset elf (+ string-table-offset value)))
                        (value  (pointer->string
                                 (bytevector->pointer (elf-bytes elf) offset))))
                   (dynamic-entry type value offset))
                 (dynamic-entry type value (dynamic-entry-offset entry))))
            (else
             (dynamic-entry type value (dynamic-entry-offset entry))))))

  (map interpret-dynamic-entry entries))

;;;
;;; High-level interface.
;;;

(define-record-type <elf-dynamic-info>
  (%elf-dynamic-info soname needed rpath runpath)
  elf-dynamic-info?
  (soname    elf-dynamic-info-soname)
  (needed    elf-dynamic-info-needed)
  (rpath     elf-dynamic-info-rpath)
  (runpath   elf-dynamic-info-runpath))

(define search-path->list
  (let ((not-colon (char-set-complement (char-set #\:))))
    (lambda (str)
      "Split STR on ':' characters."
      (string-tokenize str not-colon))))

(define (elf-dynamic-info elf)
  "Return dynamic-link information for ELF as an <elf-dynamic-info> object, or
#f if ELF lacks dynamic-link information."
  (define (matching-entry type)
    (lambda (entry)
      (= type (dynamic-entry-type entry))))

  (match (dynamic-link-segment elf)
    (#f #f)
    ((? elf-segment? dynamic)
     (let ((entries (dynamic-entries elf dynamic)))
       (%elf-dynamic-info (find (matching-entry DT_SONAME) entries)
                          (filter-map (lambda (entry)
                                        (and (= (dynamic-entry-type entry)
                                                DT_NEEDED)
                                             (dynamic-entry-value entry)))
                                      entries)
                          (or (and=> (find (matching-entry DT_RPATH)
                                           entries)
                                     (compose search-path->list
                                              dynamic-entry-value))
                              '())
                          (or (and=> (find (matching-entry DT_RUNPATH)
                                           entries)
                                     (compose search-path->list
                                              dynamic-entry-value))
                              '()))))))

(define %libc-libraries
  ;; List of libraries as of glibc 2.21 (there are more but those are
  ;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.)
  '("libanl.so"
    "libcrypt.so"
    "libc.so"
    "libdl.so"
    "libm.so"
    "libnsl.so"                                   ;NEEDED by nscd
    "libpthread.so"
    "libresolv.so"
    "librt.so"
    "libutil.so"))

(define (libc-library? lib)
  "Return #t if LIB is one of the libraries shipped with the GNU C Library."
  (find (lambda (libc-lib)
          (string-prefix? libc-lib lib))
        %libc-libraries))

(define (expand-variable str variable value)
  "Replace occurrences of '$VARIABLE' or '${VARIABLE}' in STR with VALUE."
  (define variables
    (list (string-append "$" variable)
          (string-append "${" variable "}")))

  (let loop ((thing variables)
             (str   str))
    (match thing
      (()
       str)
      ((head tail ...)
       (let ((index (string-contains str head))
             (len   (string-length head)))
         (loop (if index variables tail)
               (if index
                   (string-replace str value
                                   index (+ index len))
                   str)))))))

(define (expand-origin str directory)
  "Replace occurrences of '$ORIGIN' in STR with DIRECTORY."
  (expand-variable str "ORIGIN" directory))

(define* (validate-needed-in-runpath file
                                     #:key (always-found? libc-library?))
  "Return #t if all the libraries listed as FILE's 'DT_NEEDED' entries are
present in its RUNPATH, or if FILE lacks dynamic-link information.  Return #f
otherwise.  Libraries whose name matches ALWAYS-FOUND? are considered to be
always available."
  (guard (c ((invalid-segment-size? c)
             (let ((segment (invalid-segment-size-segment c)))
               (format (current-error-port)
                       "~a: error: offset + size of segment ~a (type ~a) \
exceeds total size~%"
                       file
                       (elf-segment-index segment)
                       (elf-segment-type segment))
               #f)))

    (let* ((elf     (call-with-input-file file
                      (compose parse-elf get-bytevector-all)))
           (expand  (cute expand-origin <> (dirname file)))
           (dyninfo (elf-dynamic-info elf)))
      (when dyninfo
        ;; XXX: In theory we should also expand $PLATFORM and $LIB, but these
        ;; appear to be really unused.
        (let* ((expanded  (map expand (elf-dynamic-info-runpath dyninfo)))
               (runpath   (filter store-file-name? expanded))
               (bogus     (remove store-file-name? expanded))
               (needed    (remove always-found?
                                  (elf-dynamic-info-needed dyninfo)))
               (not-found (remove (cut search-path runpath <>)
                                  needed)))
          (unless (null? bogus)
            (format (current-error-port)
                    "~a: warning: RUNPATH contains bogus entries: ~s~%"
                    file bogus))

          (for-each (lambda (lib)
                      (format (current-error-port)
                              "~a: error: depends on '~a', which cannot \
be found in RUNPATH ~s~%"
                              file lib runpath))
                    not-found)
          ;; (when (null? not-found)
          ;;   (format (current-error-port) "~a is OK~%" file))
          (null? not-found))))))

(define (strip-runpath file)
  "Remove from the DT_RUNPATH of FILE any entries that are not necessary
according to DT_NEEDED."
  (define (minimal-runpath needed runpath)
    (filter (lambda (directory)
              (and (string-prefix? "/" directory)
                   (any (lambda (lib)
                          (file-exists? (string-append directory "/" lib)))
                        needed)))
            runpath))

  (define port
    (open-file file "r+b"))

  (catch #t
    (lambda ()
      (let* ((elf      (parse-elf (get-bytevector-all port)))
             (entries  (dynamic-entries elf (dynamic-link-segment elf)))
             (needed   (filter-map (lambda (entry)
                                     (and (= (dynamic-entry-type entry)
                                             DT_NEEDED)
                                          (dynamic-entry-value entry)))
                                   entries))
             (runpath  (find (lambda (entry)
                               (= DT_RUNPATH (dynamic-entry-type entry)))
                             entries))
             (old      (search-path->list
                        (dynamic-entry-value runpath)))
             (new      (minimal-runpath needed old)))
        (unless (equal? old new)
          (format (current-error-port)
                  "~a: stripping RUNPATH to ~s (removed ~s)~%"
                  file new
                  (lset-difference string=? old new))
          (seek port (dynamic-entry-offset runpath) SEEK_SET)
          (put-bytevector port (string->utf8 (string-join new ":")))
          (put-u8 port 0))
        (close-port port)
        new))
    (lambda (key . args)
      (false-if-exception (close-port port))
      (apply throw key args))))

;;; gremlin.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build guile-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 format)
  #:use-module (guix build utils)
  #:export (target-guile-effective-version
            %standard-phases
            guile-build))

(define* (target-guile-effective-version #:optional guile)
  "Return the effective version of GUILE or whichever 'guile' is in $PATH.
Return #false if it cannot be determined."
  (let* ((pipe (open-pipe* OPEN_READ
                           (if guile
                               (string-append guile "/bin/guile")
                               "guile")
                           "-c" "(display (effective-version))"))
         (line (read-line pipe)))
    (and (zero? (close-pipe pipe))
         (string? line)
         line)))

(define (file-sans-extension file)                ;TODO: factorize
  "Return the substring of FILE without its extension, if any."
  (let ((dot (string-rindex file #\.)))
    (if dot
        (substring file 0 dot)
        file)))

(define %scheme-file-regexp
  ;; Regexp to match Scheme files.
  "\\.(scm|sls)$")

(define %documentation-file-regexp
  ;; Regexp to match README files and the likes.
  "^(README.*|.*\\.html|.*\\.org|.*\\.md)$")

(define* (set-locale-path #:key inputs native-inputs
                          #:allow-other-keys)
  "Set 'GUIX_LOCPATH'."
  (match (assoc-ref (or native-inputs inputs) "locales")
    (#f #t)
    (locales
     (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))
     #t)))

(define* (invoke-each commands
                      #:key (max-processes (current-processor-count))
                      report-progress)
  "Run each command in COMMANDS in a separate process, using up to
MAX-PROCESSES processes in parallel.  Call REPORT-PROGRESS at each step.
Raise an error if one of the processes exit with non-zero."
  (define total
    (length commands))

  (define processes
    (make-hash-table))

  (define (wait-for-one-process)
    (match (waitpid WAIT_ANY)
      ((pid . status)
       (let ((command (hashv-ref processes pid)))
         (hashv-remove! processes command)
         (unless (zero? (status:exit-val status))
           (format (current-error-port)
                   "process '~{~a ~}' failed with status ~a~%"
                   command status)
           (exit 1))))))

  (define (fork-and-run-command command)
    (match (primitive-fork)
      (0
       (dynamic-wind
         (const #t)
         (lambda ()
           (apply execlp command))
         (lambda ()
           (primitive-exit 127))))
      (pid
       (hashv-set! processes pid command)
       #t)))

  (let loop ((commands  commands)
             (running   0)
             (completed 0))
    (match commands
      (()
       (or (zero? running)
           (let ((running   (- running 1))
                 (completed (+ completed 1)))
             (wait-for-one-process)
             (report-progress total completed)
             (loop commands running completed))))
      ((command . rest)
       (if (< running max-processes)
           (let ((running (+ 1 running)))
             (fork-and-run-command command)
             (loop rest running completed))
           (let ((running   (- running 1))
                 (completed (+ completed 1)))
             (wait-for-one-process)
             (report-progress total completed)
             (loop commands running completed)))))))

(define* (report-build-progress total completed
                                #:optional (log-port (current-error-port)))
  "Report that COMPLETED out of TOTAL files have been completed."
  (format log-port "[~2d/~2d] Compiling...~%"
          completed total)
  (force-output log-port))

(define* (build #:key outputs inputs native-inputs
                (source-directory ".")
                (compile-flags '())
                (scheme-file-regexp %scheme-file-regexp)
                (not-compiled-file-regexp #f)
                target
                #:allow-other-keys)
  "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP.  Files
matching NOT-COMPILED-FILE-REGEXP, if true, are not compiled but are
installed; this is useful for files that are meant to be included."
  (let* ((out        (assoc-ref outputs "out"))
         (guile      (assoc-ref (or native-inputs inputs) "guile"))
         (effective  (target-guile-effective-version guile))
         (module-dir (string-append out "/share/guile/site/"
                                    effective))
         (go-dir     (string-append out "/lib/guile/"
                                    effective "/site-ccache/"))
         (guild      (string-append guile "/bin/guild"))
         (flags      (if target
                         (cons (string-append "--target=" target)
                               compile-flags)
                         compile-flags)))
    (if target
        (format #t "Cross-compiling for '~a' with Guile ~a...~%"
                target effective)
        (format #t "Compiling with Guile ~a...~%" effective))
    (format #t "compile flags: ~s~%" flags)

    ;; Make installation directories.
    (mkdir-p module-dir)
    (mkdir-p go-dir)

    ;; Compile .scm files and install.
    (setenv "GUILE_AUTO_COMPILE" "0")
    (setenv "GUILE_LOAD_COMPILED_PATH"
            (string-append go-dir
                           (match (getenv "GUILE_LOAD_COMPILED_PATH")
                             (#f "")
                             (path (string-append ":" path)))))

  (let ((source-files
           (with-directory-excursion source-directory
             (find-files "." scheme-file-regexp))))
    (invoke-each
     (filter-map (lambda (file)
                   (and (or (not not-compiled-file-regexp)
                            (not (string-match not-compiled-file-regexp
                                               file)))
                        (cons* guild
                               "guild" "compile"
                               "-L" source-directory
                               "-o" (string-append go-dir
                                                   (file-sans-extension file)
                                                   ".go")
                               (string-append source-directory "/" file)
                               flags)))
                 source-files)
     #:max-processes (parallel-job-count)
     #:report-progress report-build-progress)

    (for-each
     (lambda (file)
         (install-file (string-append source-directory "/" file)
                       (string-append module-dir
                                      "/" (dirname file))))
     source-files))
    #t))

(define* (install-documentation #:key outputs
                                (documentation-file-regexp
                                 %documentation-file-regexp)
                                #:allow-other-keys)
  "Install files that mactch DOCUMENTATION-FILE-REGEXP."
  (let* ((out (assoc-ref outputs "out"))
         (doc (string-append out "/share/doc/"
                             (strip-store-file-name out))))
    (for-each (cut install-file <> doc)
              (find-files "." documentation-file-regexp))
    #t))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (add-before 'install-locale 'set-locale-path
      set-locale-path)
    (replace 'build build)
    (add-after 'build 'install-documentation
      install-documentation)
    (delete 'check)
    (delete 'strip)
    (delete 'validate-runpath)
    (delete 'install)))

(define* (guile-build #:key (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given Guile package, applying all of PHASES in order."
  (apply gnu:gnu-build #:phases phases args))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build haskell-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 ftw)
  #:export (%standard-phases
            haskell-build))

;; Commentary:
;;
;; Builder-side code of the standard Haskell package build procedure.
;;
;; The Haskell compiler, to find libraries, relies on a library database with
;; a binary cache. For GHC the cache has to be named 'package.cache'. If every
;; library would generate the cache at build time, then they would clash in
;; profiles. For this reason we do not generate the cache when we generate
;; libraries substitutes. Instead:
;;
;; - At build time we use the 'setup-compiler' phase to generate a temporary
;;   library database and its cache.
;;
;; - We generate the cache when a profile is created.
;;
;; Code:

;; Directory where we create the temporary libraries database with its cache
;; as required by the compiler.
(define %tmp-db-dir
  (string-append (or (getenv "TMP") "/tmp")
                 "/package.conf.d"))

(define (run-setuphs command params)
  (let ((setup-file (cond
                     ((file-exists? "Setup.hs")
                      "Setup.hs")
                     ((file-exists? "Setup.lhs")
                      "Setup.lhs")
                     (else
                      #f))))
    (if setup-file
        (begin
          (format #t "running \"runhaskell Setup.hs\" with command ~s \
and parameters ~s~%"
                  command params)
          (apply invoke "runhaskell" setup-file command params))
        (error "no Setup.hs nor Setup.lhs found"))))

(define* (configure #:key outputs inputs tests? (configure-flags '())
                    (extra-directories '()) #:allow-other-keys)
  "Configure a given Haskell package."
  (let* ((out (assoc-ref outputs "out"))
         (doc (assoc-ref outputs "doc"))
         (lib (assoc-ref outputs "lib"))
         (name-version (strip-store-file-name out))
         (extra-dirs (filter-map (cut assoc-ref inputs <>) extra-directories))
         (ghc-path (getenv "GHC_PACKAGE_PATH"))
         (params `(,(string-append "--prefix=" out)
                   ,(string-append "--libdir=" (or lib out) "/lib")
                   ,(string-append "--docdir=" (or doc out)
                                   "/share/doc/" name-version)
                   "--libsubdir=$compiler/$pkg-$version"
                   ,(string-append "--package-db=" %tmp-db-dir)
                   "--global"
                   ,@(map (cut string-append "--extra-include-dirs=" <>)
                          (search-path-as-list '("include") extra-dirs))
                   ,@(map (cut string-append "--extra-lib-dirs=" <>)
                          (search-path-as-list '("lib") extra-dirs))
                   ,@(if tests?
                         '("--enable-tests")
                         '())
                   ;; Build and link with shared libraries
                   "--enable-shared"
                   "--enable-executable-dynamic"
                   "--ghc-option=-fPIC"
                   ,(string-append "--ghc-option=-optl=-Wl,-rpath=" (or lib out)
                                   "/lib/$compiler/$pkg-$version")
                   ,@configure-flags)))
    ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset
    ;; and restore it.
    (unsetenv "GHC_PACKAGE_PATH")

    ;; For packages where the Cabal build-type is set to "Configure",
    ;; ./configure will be executed.  In these cases, the following
    ;; environment variable is needed to be able to find the shell executable.
    ;; For other package types, the configure script isn't present.  For more
    ;; information, see the Build Information section of
    ;; <https://www.haskell.org/cabal/users-guide/developing-packages.html>.
    (when (file-exists? "configure")
      (setenv "CONFIG_SHELL" "sh"))
    (run-setuphs "configure" params)

    (setenv "GHC_PACKAGE_PATH" ghc-path)
    #t))

(define* (build #:key parallel-build? #:allow-other-keys)
  "Build a given Haskell package."
  (run-setuphs "build"
               (if parallel-build?
                   `(,(string-append "--ghc-option=-j" (number->string (parallel-job-count))))
                   '())))

(define* (install #:key outputs #:allow-other-keys)
  "Install a given Haskell package."
  (run-setuphs "copy" '())
  (when (assoc-ref outputs "static")
    (let ((static (assoc-ref outputs "static"))
          (lib (or (assoc-ref outputs "lib")
                   (assoc-ref outputs "out"))))
      (for-each (lambda (static-lib)
                  (let* ((subdir (string-drop static-lib (string-length lib)))
                         (new    (string-append static subdir)))
                    (mkdir-p (dirname new))
                    (rename-file static-lib new)))
                (find-files lib "\\.a$"))))
  #t)

(define (grep rx port)
  "Given a regular-expression RX including a group, read from PORT until the
first match and return the content of the group."
  (let ((line (read-line port)))
    (if (eof-object? line)
        #f
        (let ((rx-result (regexp-exec rx line)))
          (if rx-result
              (match:substring rx-result 1)
              (grep rx port))))))

(define* (setup-compiler #:key system inputs outputs #:allow-other-keys)
  "Setup the compiler environment."
  (let* ((haskell (assoc-ref inputs "haskell"))
         (name-version (strip-store-file-name haskell)))
    (cond
     ((string-match "ghc" name-version)
      (make-ghc-package-database system inputs outputs))
     (else
      (format #t
              "Compiler ~a not supported~%" name-version)))))

;;; TODO: Move this to (guix build utils)?
(define-syntax-rule (with-null-error-port exp)
  "Evaluate EXP with the error port pointing to the bit bucket."
  (with-error-to-port (%make-void-port "w")
    (lambda () exp)))

(define (make-ghc-package-database system inputs outputs)
  "Generate the GHC package database."
  (let* ((haskell  (assoc-ref inputs "haskell"))
         (name-version (strip-store-file-name haskell))
         (input-dirs (match inputs
                       (((_ . dir) ...)
                        dir)
                       (_ '())))
         ;; Silence 'find-files' (see 'evaluate-search-paths')
         (conf-dirs (with-null-error-port
                     (search-path-as-list
                      `(,(string-append "lib/" name-version))
                      input-dirs #:pattern ".*\\.conf.d$")))
         (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs)))
    (mkdir-p %tmp-db-dir)
    (for-each (lambda (file)
                (let ((dest (string-append %tmp-db-dir "/" (basename file))))
                  (unless (file-exists? dest)
                    (copy-file file dest))))
              conf-files)
    (invoke "ghc-pkg"
            (string-append "--package-db=" %tmp-db-dir)
            "recache")
    #t))

(define* (register #:key name system inputs outputs #:allow-other-keys)
  "Generate the compiler registration and binary package database files for a
given Haskell package."

  (define (conf-depends conf-file)
    ;; Return a list of pkg-ids from the "depends" field in CONF-FILE
    (let ((port (open-input-file conf-file))
          (field-rx (make-regexp "^(.*):")))
      (let loop ((collecting #f)
                 (deps '()))
        (let* ((line (read-line port))
               (field (and=> (and (not (eof-object? line))
                                  (regexp-exec field-rx line))
                             (cut match:substring <> 1))))
          (cond
           ((and=> field (cut string=? <> "depends"))
            ;; The first dependency is listed on the same line as "depends:",
            ;; so drop those characters.  A line may list more than one .conf.
            (let ((d (string-tokenize (string-drop line 8))))
              (loop #t (append d deps))))
           ((or (eof-object? line) (and collecting field))
            (begin
              (close-port port)
              (reverse! deps)))
           (collecting
            (loop #t (append (string-tokenize line) deps)))
           (else (loop #f deps)))))))

  (define (install-transitive-deps conf-file src dest)
    ;; Copy .conf files from SRC to DEST for dependencies in CONF-FILE, and
    ;; their dependencies, etc.
    (let loop ((seen vlist-null)
               (lst (conf-depends conf-file)))
      (match lst
        (() #t)                         ;done
        ((id . tail)
         (if (not (vhash-assoc id seen))
             (let ((dep-conf  (string-append src  "/" id ".conf"))
                   (dep-conf* (string-append dest "/" id ".conf")))
               (copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead?
               (loop (vhash-cons id #t seen)
                     (append lst (conf-depends dep-conf))))
             (loop seen tail))))))

  (let* ((out (assoc-ref outputs "out"))
         (doc (assoc-ref outputs "doc"))
         (haskell  (assoc-ref inputs "haskell"))
         (name-verion (strip-store-file-name haskell))
         (lib (string-append (or (assoc-ref outputs "lib") out) "/lib"))
         (config-dir (string-append lib
                                    "/" name-verion
                                    "/" name ".conf.d"))
         (id-rx (make-regexp "^id: *(.*)$"))
         (config-file (string-append out "/" name ".conf"))
         (params
          (list (string-append "--gen-pkg-config=" config-file))))
    (run-setuphs "register" params)
    ;; The conf file is created only when there is a library to register.
    (when (file-exists? config-file)
      (mkdir-p config-dir)
      (let ((config-file-name+id
             (call-with-ascii-input-file config-file (cut grep id-rx <>))))

        ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the
        ;; "haddock-interfaces" field and removing the optional "haddock-html"
        ;; field in the generated .conf file.
        (when doc
          (substitute* config-file
            (("^haddock-html: .*") "\n")
            (((format #f "^haddock-interfaces: ~a" doc))
             (string-append "haddock-interfaces: " lib)))
          ;; Move the referenced file to the "lib" (or "out") output.
          (match (find-files doc "\\.haddock$")
            ((haddock-file . rest)
             (let* ((subdir (string-drop haddock-file (string-length doc)))
                    (new    (string-append lib subdir)))
               (mkdir-p (dirname new))
               (rename-file haddock-file new)))
            (_ #f)))
        (install-transitive-deps config-file %tmp-db-dir config-dir)
        (rename-file config-file
                     (string-append config-dir "/"
                                    config-file-name+id ".conf"))
        (invoke "ghc-pkg"
                (string-append "--package-db=" config-dir)
                "recache")))
    #t))

(define* (check #:key tests? test-target #:allow-other-keys)
  "Run the test suite of a given Haskell package."
  (if tests?
      (run-setuphs test-target '())
      (format #t "test suite not run~%"))
  #t)

(define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys)
  "Generate the Haddock documentation of a given Haskell package."
  (when haddock?
    (run-setuphs "haddock" haddock-flags))
  #t)

(define* (patch-cabal-file #:key cabal-revision #:allow-other-keys)
  (when cabal-revision
    ;; Cabal requires there to be a single file with the suffix ".cabal".
    (match (scandir "." (cut string-suffix? ".cabal" <>))
      ((original)
       (format #t "replacing ~s with ~s~%" original cabal-revision)
       (copy-file cabal-revision original))
      (_ (error "Could not find a Cabal file to patch."))))
  #t)

(define* (generate-setuphs #:rest empty)
  "Generate a default Setup.hs if needed."
  (when (not (or (file-exists? "Setup.hs")
                 (file-exists? "Setup.lhs")))
    (format #t "generating missing Setup.hs~%")
    (with-output-to-file "Setup.hs"
      (lambda ()
        (format #t "import Distribution.Simple~%")
        (format #t "main = defaultMain~%"))))
  #t)

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (add-after 'unpack 'patch-cabal-file patch-cabal-file)
    (add-after 'unpack 'generate-setuphs generate-setuphs)
    (delete 'bootstrap)
    (add-before 'configure 'setup-compiler setup-compiler)
    (add-before 'install 'haddock haddock)
    (add-after 'install 'register register)
    (replace 'install install)
    (replace 'check check)
    (replace 'build build)
    (replace 'configure configure)))

(define* (haskell-build #:key inputs (phases %standard-phases)
                        #:allow-other-keys #:rest args)
  "Build the given Haskell package, applying all of PHASES in order."
  (apply gnu:gnu-build
         #:inputs inputs #:phases phases
         args))

;;; haskell-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build hg)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-34)
  #:use-module (ice-9 format)
  #:export (hg-fetch))

;;; Commentary:
;;;
;;; This is the build-side support code of (guix hg-download).  It allows a
;;; Mercurial repository to be cloned and checked out at a specific changeset
;;; identifier.
;;;
;;; Code:

(define* (hg-fetch url changeset directory
                   #:key (hg-command "hg"))
  "Fetch CHANGESET from URL into DIRECTORY.  CHANGESET must be a valid
Mercurial changeset identifier.  Return #t on success, #f otherwise."

  (mkdir-p directory)

  (guard (c ((invoke-error? c)
             (report-invoke-error c)
             (delete-file-recursively directory)
             #f))
    (with-directory-excursion directory
      (invoke hg-command
              "clone" url
              "--rev" changeset
              ;; Disable TLS certificate verification.  The hash of
              ;; the checkout is known in advance anyway.
              "--insecure"
              directory)

      ;; The contents of '.hg' vary as a function of the current
      ;; status of the Mercurial repo.  Since we want a fixed
      ;; output, this directory needs to be taken out.
      ;; Since the '.hg' file is also in sub-modules, we have to
      ;; search for it in all sub-directories.
      (for-each delete-file-recursively
                (find-files directory "^\\.hg$" #:directories? #t))

      #t)))

;;; hg.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
;;; Copyright © 2020, 2021 Julien Lepiller <julien@lepiller.eu>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build java-utils)
  #:use-module (guix build utils)
  #:use-module (guix build syscalls)
  #:use-module (guix build maven pom)
  #:use-module (guix build maven plugin)
  #:use-module (ice-9 match)
  #:use-module (sxml simple)
  #:export (ant-build-javadoc
            generate-plugin.xml
            generate-pom.xml
            install-jars
            install-javadoc
            install-pom-file
            install-from-pom))

(define* (ant-build-javadoc #:key (target "javadoc") (make-flags '())
                            #:allow-other-keys)
  (apply invoke `("ant" ,target ,@make-flags)))

(define* (install-jars jar-directory)
  "Install jar files from JAR-DIRECTORY to the default target directory.  This
is used in case the build.xml does not include an install target."
  (lambda* (#:key outputs #:allow-other-keys)
    (let ((share (string-append (assoc-ref outputs "out")
                                "/share/java")))
      (for-each (lambda (f) (install-file f share))
                (find-files jar-directory "\\.jar$"))
      #t)))

(define* (install-javadoc apidoc-directory)
  "Install the APIDOC-DIRECTORY to the target directory.  This is used to
install javadocs when this is not done by the install target."
  (lambda* (#:key outputs #:allow-other-keys)
    (let* ((out (assoc-ref outputs "out"))
           (name-version (strip-store-file-name out))
           (docs (string-append (or (assoc-ref outputs "doc") out)
                                "/share/doc/" name-version "/")))
      (mkdir-p docs)
      (copy-recursively apidoc-directory docs)
      #t)))

(define* (install-pom-file pom-file)
  "Install a @file{.pom} file to a maven repository structure in @file{lib/m2}
that respects the file's artifact ID and group ID.  This requires the parent
pom, if any, to be present in the inputs so some of this information can be
fetched."
  (lambda* (#:key inputs outputs #:allow-other-keys)
    (let* ((out (assoc-ref outputs "out"))
           (java-inputs (append (map cdr inputs) (map cdr outputs)))
           (pom-content (get-pom pom-file))
           (version (pom-version pom-content))
           (artifact (pom-artifactid pom-content))
           (group (group->dir (pom-groupid pom-content)))
           (repository (string-append out "/lib/m2/" group "/" artifact "/"
                                      version "/"))
           (pom-name (string-append repository artifact "-" version ".pom")))
      (mkdir-p (dirname pom-name))
      (copy-file pom-file pom-name))
    #t))

(define (install-jar-file-with-pom jar pom-file inputs)
  "Unpack the jar archive, add the pom file, and repack it.  This is necessary
to ensure that maven can find dependencies."
  (format #t "adding ~a to ~a\n" pom-file jar)
  (let* ((dir (mkdtemp! "jar-contents.XXXXXX"))
         (manifest (string-append dir "/META-INF/MANIFEST.MF"))
         (pom (get-pom pom-file))
         (artifact (pom-artifactid pom))
         (group (pom-groupid pom))
         (version (pom-version pom))
         (pom-dir (string-append "META-INF/maven/" group "/" artifact)))
    (mkdir-p (string-append dir "/" pom-dir))
    (copy-file pom-file (string-append dir "/" pom-dir "/pom.xml"))
    (with-directory-excursion dir
      (with-output-to-file (string-append pom-dir "/pom.properties")
        (lambda _
          (format #t "version=~a~%" version)
          (format #t "groupId=~a~%" group)
          (format #t "artifactId=~a~%" artifact)))
      (invoke "jar" "uf" jar (string-append pom-dir "/pom.xml")
              (string-append pom-dir "/pom.properties")))
    #t))

(define* (install-from-pom pom-file)
  "Install a jar archive and its @var{pom-file} to a maven repository structure
in @file{lib/m2}.  This requires the parent pom file, if any, to be present in
the inputs of the package being built.  This phase looks either for a properly
named jar file (@file{artifactID-version.jar}) or the single jar in the build
directory.  If there are more than one jar, and none is named appropriately,
the phase fails."
  (lambda* (#:key inputs outputs jar-name #:allow-other-keys)
    (let* ((out (assoc-ref outputs "out"))
           (java-inputs (append (map cdr inputs) (map cdr outputs)))
           (pom-content (get-pom pom-file))
           (version (pom-version pom-content))
           (artifact (pom-artifactid pom-content))
           (group (group->dir (pom-groupid pom-content)))
           (repository (string-append out "/lib/m2/" group "/" artifact "/"
                                      version "/"))
           ;; We try to find the file that was built.  If it was built from our
           ;; generated ant.xml file, it is name jar-name, otherwise it should
           ;; have the expected name for maven.
           (jars (find-files "." (or jar-name (string-append artifact "-"
                                                             version ".jar"))))
           ;; Otherwise, we try to find any jar file.
           (jars (if (null? jars)
                     (find-files "." "\\.jar$")
                     jars))
           (jar-name (string-append repository artifact "-" version ".jar"))
           (pom-name (string-append repository artifact "-" version ".pom")))
      ;; Ensure we can override the file
      (chmod pom-file #o644)
      (fix-pom-dependencies pom-file java-inputs)
      (mkdir-p (dirname jar-name))
      (copy-file pom-file pom-name)
      ;; If there are too many jar files, we don't know which one to install, so
      ;; fail.
      (if (= (length jars) 1)
          (begin
            (copy-file (car jars) jar-name)
            (install-jar-file-with-pom jar-name pom-file java-inputs))
          (throw 'no-jars jars)))
    #t))

(define (sxml-indent sxml)
  "Adds some indentation to @var{sxml}, an sxml value, to make reviewing easier
after the value is written to an xml file."
  (define (sxml-indent-aux sxml lvl)
    (match sxml
      ((? string? str) str)
      ((tag ('@ attr ...) content ...)
       (cond
         ((null? content) sxml)
         ((string? (car content)) sxml)
         (else
           `(,tag (@ ,@attr) ,(sxml-indent-content content (+ lvl 1))))))
      ((tag content ...)
       (cond
         ((null? content) sxml)
         ((string? (car content)) sxml)
         (else `(,tag ,(sxml-indent-content content (+ lvl 1))))))
      (_ sxml)))
  (define (sxml-indent-content sxml lvl)
    (map
      (lambda (sxml)
        (list "\n" (string-join (make-list (* 2 lvl) " ") "")
              (sxml-indent-aux sxml lvl)))
      sxml))
  (sxml-indent-aux sxml 0))

(define* (generate-plugin.xml pom-file goal-prefix directory source-groups
                              #:key
                              (plugin.xml "build/classes/META-INF/maven/plugin.xml"))
  "Generates the @file{plugin.xml} file that is required by Maven so it can
recognize the package as a plugin, and find the entry points in the plugin."
  (lambda* (#:key inputs outputs #:allow-other-keys)
    (let* ((pom-content (get-pom pom-file))
           (java-inputs (append (map cdr inputs) (map cdr outputs)))
           (name (pom-name pom-content))
           (description (pom-description pom-content))
           (dependencies (pom-dependencies pom-content))
           (version (pom-version pom-content))
           (artifact (pom-artifactid pom-content))
           (groupid (pom-groupid pom-content))
           (mojos
            `(mojos
               ,@(with-directory-excursion directory
                   (map
                     (lambda (group)
                       (apply generate-mojo-from-files maven-convert-type group))
                     source-groups)))))
      (mkdir-p (dirname plugin.xml))
      (with-output-to-file plugin.xml
        (lambda _
          (sxml->xml
            (sxml-indent
              `(plugin
                 (name ,name)
                 (description ,description)
                 (groupId ,groupid)
                 (artifactId ,artifact)
                 (version ,version)
                 (goalPrefix ,goal-prefix)
                 (isolatedRealm "false")
                 (inheritedByDefault "true")
                 ,mojos
                 (dependencies
                  ,@dependencies)))))))))

(define* (generate-pom.xml pom-file groupid artifactid version
                           #:key (dependencies '())
                                 (name artifactid))
  "Generates the @file{pom.xml} for a project. It is required by Maven to find
a package, and by the java build system to know where to install a package, when
a pom.xml doesn't already exist and installing to the maven repository."
  (lambda _
    (mkdir-p (dirname pom-file))
    (with-output-to-file pom-file
      (lambda _
        (sxml->xml
          (sxml-indent
            `(project
               (modelVersion "4.0.0")
               (name ,name)
               (groupId ,groupid)
               (artifactId ,artifactid)
               (version ,version)
               (dependencies
                ,@(map
                    (match-lambda
                      ((groupid artifactid version)
                      `(dependency
                         (groupId ,groupid)
                         (artifactId ,artifactid)
                         (version ,version))))
                    dependencies)))))))))


code:
;;;; json.scm --- JSON reader/writer
;;;; Copyright (C) 2015 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (guix build json)  ;; originally (ice-9 json)
  #:use-module (ice-9 match)
  #:export (read-json write-json))

;; Snarfed from
;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm
;;

;;;
;;; Reader
;;;

(define (json-error port)
  (throw 'json-error port))

(define (assert-char port char)
  "Read a character from PORT and throw an invalid JSON error if the
character is not CHAR."
  (unless (eqv? (read-char port) char)
    (json-error port)))

(define (whitespace? char)
  "Return #t if CHAR is a whitespace character."
  (char-set-contains? char-set:whitespace char))

(define (consume-whitespace port)
  "Discard characters from PORT until a non-whitespace character is
encountered.."
  (match (peek-char port)
    ((? eof-object?) *unspecified*)
    ((? whitespace?)
     (read-char port)
     (consume-whitespace port))
    (_ *unspecified*)))

(define (make-keyword-reader keyword value)
  "Parse the keyword symbol KEYWORD as VALUE."
  (let ((str (symbol->string keyword)))
    (lambda (port)
      (let loop ((i 0))
        (cond
         ((= i (string-length str)) value)
         ((eqv? (string-ref str i) (read-char port))
          (loop (1+ i)))
         (else (json-error port)))))))

(define read-true (make-keyword-reader 'true #t))
(define read-false (make-keyword-reader 'false #f))
(define read-null (make-keyword-reader 'null #nil))

(define (read-hex-digit port)
  "Read a hexadecimal digit from PORT."
  (match (read-char port)
    (#\0 0)
    (#\1 1)
    (#\2 2)
    (#\3 3)
    (#\4 4)
    (#\5 5)
    (#\6 6)
    (#\7 7)
    (#\8 8)
    (#\9 9)
    ((or #\A #\a) 10)
    ((or #\B #\b) 11)
    ((or #\C #\c) 12)
    ((or #\D #\d) 13)
    ((or #\E #\e) 14)
    ((or #\F #\f) 15)
    (_ (json-error port))))

(define (read-utf16-character port)
  "Read a hexadecimal encoded UTF-16 character from PORT."
  (integer->char
   (+ (* (read-hex-digit port) (expt 16 3))
      (* (read-hex-digit port) (expt 16 2))
      (* (read-hex-digit port) 16)
      (read-hex-digit port))))

(define (read-escape-character port)
  "Read escape character from PORT."
  (match (read-char port)
    (#\" #\")
    (#\\ #\\)
    (#\/ #\/)
    (#\b #\backspace)
    (#\f #\page)
    (#\n #\newline)
    (#\r #\return)
    (#\t #\tab)
    (#\u (read-utf16-character port))
    (_ (json-error port))))

(define (read-string port)
  "Read a JSON encoded string from PORT."
  (assert-char port #\")
  (let loop ((result '()))
    (match (read-char port)
      ((? eof-object?) (json-error port))
      (#\" (list->string (reverse result)))
      (#\\ (loop (cons (read-escape-character port) result)))
      (char (loop (cons char result))))))

(define char-set:json-digit
  (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))

(define (digit? char)
  (char-set-contains? char-set:json-digit char))

(define (read-digit port)
  "Read a digit 0-9 from PORT."
  (match (read-char port)
    (#\0 0)
    (#\1 1)
    (#\2 2)
    (#\3 3)
    (#\4 4)
    (#\5 5)
    (#\6 6)
    (#\7 7)
    (#\8 8)
    (#\9 9)
    (else (json-error port))))

(define (read-digits port)
  "Read a sequence of digits from PORT."
  (let loop ((result '()))
    (match (peek-char port)
      ((? eof-object?)
       (reverse result))
      ((? digit?)
       (loop (cons (read-digit port) result)))
      (else (reverse result)))))

(define (list->integer digits)
  "Convert the list DIGITS to an integer."
  (let loop ((i (1- (length digits)))
             (result 0)
             (digits digits))
    (match digits
      (() result)
      ((n . tail)
       (loop (1- i)
             (+ result (* n (expt 10 i)))
             tail)))))

(define (read-positive-integer port)
  "Read a positive integer with no leading zeroes from PORT."
  (match (read-digits port)
    ((0 . _)
     (json-error port)) ; no leading zeroes allowed
    ((digits ...)
     (list->integer digits))))

(define (read-exponent port)
  "Read exponent from PORT."
  (define (read-expt)
    (list->integer (read-digits port)))

  (unless (memv (read-char port) '(#\e #\E))
    (json-error port))

  (match (peek-char port)
    ((? eof-object?)
     (json-error port))
    (#\-
     (read-char port)
     (- (read-expt)))
    (#\+
     (read-char port)
     (read-expt))
    ((? digit?)
     (read-expt))
    (_ (json-error port))))

(define (read-fraction port)
  "Read fractional number part from PORT as an inexact number."
  (let* ((digits      (read-digits port))
         (numerator   (list->integer digits))
         (denomenator (expt 10 (length digits))))
    (/ numerator denomenator)))

(define (read-positive-number port)
  "Read a positive number from PORT."
  (let* ((integer (match (peek-char port)
                    ((? eof-object?)
                     (json-error port))
                    (#\0
                     (read-char port)
                     0)
                    ((? digit?)
                     (read-positive-integer port))
                    (_ (json-error port))))
         (fraction (match (peek-char port)
                     (#\.
                      (read-char port)
                      (read-fraction port))
                     (_ 0)))
         (exponent (match (peek-char port)
                     ((or #\e #\E)
                      (read-exponent port))
                     (_ 0)))
         (n (* (+ integer fraction) (expt 10 exponent))))

    ;; Keep integers as exact numbers, but convert numbers encoded as
    ;; floating point numbers to an inexact representation.
    (if (zero? fraction)
        n
        (exact->inexact n))))

(define (read-number port)
  "Read a number from PORT"
  (match (peek-char port)
    ((? eof-object?)
     (json-error port))
    (#\-
     (read-char port)
     (- (read-positive-number port)))
    ((? digit?)
     (read-positive-number port))
    (_ (json-error port))))

(define (read-object port)
  "Read key/value map from PORT."
  (define (read-key+value-pair)
    (let ((key (read-string port)))
      (consume-whitespace port)
      (assert-char port #\:)
      (consume-whitespace port)
      (let ((value (read-value port)))
        (cons key value))))

  (assert-char port #\{)
  (consume-whitespace port)

  (if (eqv? #\} (peek-char port))
      (begin
        (read-char port)
        '(@)) ; empty object
      (let loop ((result (list (read-key+value-pair))))
        (consume-whitespace port)
        (match (peek-char port)
          (#\, ; read another value
           (read-char port)
           (consume-whitespace port)
           (loop (cons (read-key+value-pair) result)))
          (#\} ; end of object
           (read-char port)
           (cons '@ (reverse result)))
          (_ (json-error port))))))

(define (read-array port)
  "Read array from PORT."
  (assert-char port #\[)
  (consume-whitespace port)

  (if (eqv? #\] (peek-char port))
      (begin
        (read-char port)
        '()) ; empty array
      (let loop ((result (list (read-value port))))
        (consume-whitespace port)
        (match (peek-char port)
          (#\, ; read another value
           (read-char port)
           (consume-whitespace port)
           (loop (cons (read-value port) result)))
          (#\] ; end of array
           (read-char port)
           (reverse result))
          (_ (json-error port))))))

(define (read-value port)
  "Read a JSON value from PORT."
  (consume-whitespace port)
  (match (peek-char port)
    ((? eof-object?) (json-error port))
    (#\" (read-string port))
    (#\{ (read-object port))
    (#\[ (read-array port))
    (#\t (read-true port))
    (#\f (read-false port))
    (#\n (read-null port))
    ((or #\- (? digit?))
     (read-number port))
    (_ (json-error port))))

(define (read-json port)
  "Read JSON text from port and return an s-expression representation."
  (let ((result (read-value port)))
    (consume-whitespace port)
    (unless (eof-object? (peek-char port))
      (json-error port))
    result))

;;;
;;; Writer
;;;

(define (write-string str port)
  "Write STR to PORT in JSON string format."
  (define (escape-char char)
    (display (match char
               (#\" "\\\"")
               (#\\ "\\\\")
               (#\/ "\\/")
               (#\backspace "\\b")
               (#\page "\\f")
               (#\newline "\\n")
               (#\return "\\r")
               (#\tab "\\t")
               (_ char))
             port))

  (display "\"" port)
  (string-for-each escape-char str)
  (display "\"" port))

(define (write-object alist port)
  "Write ALIST to PORT in JSON object format."
  ;; Keys may be strings or symbols.
  (define key->string
    (match-lambda
     ((? string? key) key)
     ((? symbol? key) (symbol->string key))))

  (define (write-pair pair)
    (match pair
      ((key . value)
       (write-string (key->string key) port)
       (display ":" port)
       (write-json value port))))

  (display "{" port)
  (match alist
    (() #f)
    ((front ... end)
     (for-each (lambda (pair)
                 (write-pair pair)
                 (display "," port))
          front)
     (write-pair end)))
  (display "}" port))

(define (write-array lst port)
  "Write LST to PORT in JSON array format."
  (display "[" port)
  (match lst
    (() #f)
    ((front ... end)
     (for-each (lambda (val)
                 (write-json val port)
                 (display "," port))
               front)
     (write-json end port)))
  (display "]" port))

(define (write-json exp port)
  "Write EXP to PORT in JSON format."
  (match exp
    (#t (display "true" port))
    (#f (display "false" port))
    ;; Differentiate #nil from '().
    ((and (? boolean? ) #nil) (display "null" port))
    ((? string? s) (write-string s port))
    ((? real? n) (display n port))
    (('@ . alist) (write-object alist port))
    ((vals ...) (write-array vals port))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Nicolò Balzarotti <nicolo@nixo.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build julia-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:export (%standard-phases
            julia-create-package-toml
            julia-build))

;; Commentary:
;;
;; Builder-side code of the standard build procedure for Julia packages.
;;
;; Code:

(define (invoke-julia code)
  (invoke "julia" "-e" code))

;; subpath where we store the package content
(define %package-path "/share/julia/packages/")

(define (project.toml->name file)
  "Look for Julia package name in the TOML file FILE (usually named
Project.toml)."
  (call-with-input-file file
    (lambda (in)
      (let loop ((line (read-line in 'concat)))
        (if (eof-object? line)
            #f
            (let ((m (string-match "name\\s*=\\s*\"(.*)\"" line)))
              (if m (match:substring m 1)
                  (loop (read-line in 'concat)))))))))

(define* (install #:key source inputs outputs julia-package-name
                  #:allow-other-keys)
  (let* ((out (assoc-ref outputs "out"))
         (package-dir (string-append out %package-path
                                     (or
                                      julia-package-name
                                      (project.toml->name "Project.toml")))))
    (mkdir-p package-dir)
    (copy-recursively (getcwd) package-dir))
  #t)

(define* (precompile #:key source inputs outputs julia-package-name
                     #:allow-other-keys)
  (let* ((out (assoc-ref outputs "out"))
         (builddir (string-append out "/share/julia/"))
         (package (or julia-package-name (project.toml->name "Project.toml"))))
    (mkdir-p builddir)
    ;; With a patch, SOURCE_DATE_EPOCH is honored
    (setenv "SOURCE_DATE_EPOCH" "1")
    (setenv "JULIA_DEPOT_PATH" builddir)
    ;; Add new package dir to the load path.
    (setenv "JULIA_LOAD_PATH"
            (string-append builddir "packages/" ":"
                           (or (getenv "JULIA_LOAD_PATH")
                               "")))
    ;; Actual precompilation:
    (invoke-julia
     ;; When using Julia as a user, Julia writes precompile cache to the first
     ;; entry of the DEPOT_PATH list (by default, the home dir).  We want to
     ;; write it to the store, so let's push the store path as the first
     ;; element of DEPOT_PATH.  Once the cache file exists, this hack is not
     ;; needed anymore (like in the check phase).  If the user install new
     ;; packages, those will be installed and precompiled in the home dir.
     (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " package)))
  #t)

(define* (check #:key tests? source inputs outputs julia-package-name
                #:allow-other-keys)
  (when tests?
    (let* ((out (assoc-ref outputs "out"))
           (package (or julia-package-name (project.toml->name "Project.toml")))
           (builddir (string-append out "/share/julia/")))
      ;; With a patch, SOURCE_DATE_EPOCH is honored
      (setenv "SOURCE_DATE_EPOCH" "1")
      (setenv "JULIA_DEPOT_PATH" builddir)
      (setenv "JULIA_LOAD_PATH"
              (string-append builddir "packages/" ":"
                             (or (getenv "JULIA_LOAD_PATH")
                                 "")))
      (setenv "HOME" "/tmp")
      (invoke "julia" "--depwarn=yes"
              (string-append builddir "packages/"
                             package "/test/runtests.jl"))))
  #t)

(define (julia-create-package-toml outputs source
                                   name uuid version
                                   deps)
  "Some packages are not using the new Package.toml dependency specifications.
Write this file manually, so that Julia can find its dependencies."
  (let ((f (open-file
            (string-append
             (assoc-ref outputs "out")
             %package-path
             (string-append
              name "/Project.toml"))
            "w")))
    (display (string-append
              "
name = \"" name "\"
uuid = \"" uuid "\"
version = \"" version "\"
") f)
    (when (not (null? deps))
      (display "[deps]\n" f)
      (for-each (lambda dep
                  (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n")
                           f))
                deps))
    (close-port f))
  #t)

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'check) ; tests must be run after installation
    (replace 'install install)
    (add-after 'install 'precompile precompile)
    (add-after 'install 'check check)
    ;; TODO: In the future we could add a "system-image-generation" phase
    ;; where we use PackageCompiler.jl to speed up package loading times
    (delete 'configure)
    (delete 'bootstrap)
    (delete 'patch-usr-bin-file)
    (delete 'build)))

(define* (julia-build #:key inputs julia-package-name
                      (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given Julia package, applying all of PHASES in order."
  (apply gnu:gnu-build
         #:inputs inputs #:phases phases
         #:julia-package-name julia-package-name
         args))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build linux-module-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            linux-module-build))

;; Commentary:
;;
;; Builder-side code of linux-module build.
;;
;; Code:

;; Copied from make-linux-libre's "configure" phase.
(define* (configure #:key inputs target arch #:allow-other-keys)
  (setenv "KCONFIG_NOTIMESTAMP" "1")
  (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH"))

  (setenv "ARCH" arch)
  (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))

  (when target
    (setenv "CROSS_COMPILE" (string-append target "-"))
    (format #t "`CROSS_COMPILE' set to `~a'~%"
               (getenv "CROSS_COMPILE")))
  ; TODO: (setenv "EXTRA_VERSION" ,extra-version)
  ; TODO: kernel ".config".
  #t)

(define* (build #:key inputs make-flags #:allow-other-keys)
  (apply invoke "make" "-C"
         (string-append (assoc-ref inputs "linux-module-builder")
                        "/lib/modules/build")
         (string-append "M=" (getcwd))
         (or make-flags '())))

;; This block was copied from make-linux-libre--only took the "modules_install"
;; part.
(define* (install #:key make-flags inputs native-inputs outputs
                  #:allow-other-keys)
  (let* ((out (assoc-ref outputs "out"))
         (moddir (string-append out "/lib/modules")))
    ;; Install kernel modules
    (mkdir-p moddir)
    (apply invoke "make" "-C"
            (string-append (assoc-ref inputs "linux-module-builder")
                           "/lib/modules/build")
            (string-append "M=" (getcwd))
            ;; Disable depmod because the Guix system's module directory
            ;; is an union of potentially multiple packages.  It is not
            ;; possible to use depmod to usefully calculate a dependency
            ;; graph while building only one of those packages.
            "DEPMOD=true"
            (string-append "MODULE_DIR=" moddir)
            (string-append "INSTALL_PATH=" out)
            (string-append "INSTALL_MOD_PATH=" out)
            "INSTALL_MOD_STRIP=1"
            "modules_install"
            (or make-flags '()))))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (replace 'configure configure)
    (replace 'build build)
    (replace 'install install)))

(define* (linux-module-build #:key inputs
                             (phases %standard-phases)
                             #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order, with a Linux
kernel in attendance."
  (apply gnu:gnu-build
         #:inputs inputs #:phases phases
         args))

;;; linux-module-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build lisp-utils)
  #:use-module (ice-9 format)
  #:use-module (ice-9 hash-table)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (guix build utils)
  #:export (%lisp
            %lisp-type
            %source-install-prefix
            lisp-eval-program
            compile-systems
            test-system
            replace-escaped-macros
            generate-executable-wrapper-system
            generate-executable-entry-point
            generate-executable-for-system
            wrap-output-translations
            prepend-to-source-registry
            build-program
            build-image
            make-asdf-configuration
            valid-char-set
            normalize-string
            library-output))

;;; Commentary:
;;;
;;; Tools to evaluate lisp programs within a lisp session, generate wrapper
;;; systems for executables. Compile, test, and produce images for systems and
;;; programs, and link them with their dependencies.
;;;
;;; Code:

(define %lisp
  ;; File name of the Lisp compiler.
  (make-parameter "lisp"))

(define %lisp-type
  ;; String representing the class of implementation being used.
  (make-parameter "lisp"))

;; The common parent for Lisp source files, as will as the symbolic
;; link farm for system definition (.asd) files.
(define %source-install-prefix "/share/common-lisp")

(define (library-output outputs)
  "If a `lib' output exists, build things there. Otherwise use `out'."
  (or (assoc-ref outputs "lib") (assoc-ref outputs "out")))

;; 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 (wrap-output-translations translations)
  `(:output-translations
    ,@translations
    :inherit-configuration))

(define (lisp-eval-program program)
  "Evaluate PROGRAM with a given LISP implementation."
  (define invocation (lisp-invocation program))
  (format #t "Invoking ~a: ~{~s ~}~%" (%lisp-type) invocation)
  (apply invoke invocation))

(define (spread-statements program argument-name)
  "Return a list with the statements from PROGRAM spread between
ARGUMENT-NAME, a string representing the argument a lisp implementation uses
to accept statements to be evaluated before starting."
  (append-map (lambda (statement)
                (list argument-name (format #f "~S" statement)))
              program))

(define (lisp-invocation program)
  "Return a list of arguments for system* determining how to invoke LISP
with PROGRAM."
  (match (%lisp-type)
    ("sbcl" `(,(%lisp) "--non-interactive"
              ,@(spread-statements program "--eval")))
    ("ecl" `(,(%lisp)
             ,@(spread-statements program "--eval")
             "--eval" "(quit)"))
    (_ (error "The LISP provided is not supported at this time."))))

(define (compile-systems systems asd-files)
  "Use a lisp implementation to compile the SYSTEMS using asdf.
Load ASD-FILES first."
  (lisp-eval-program
   `((require :asdf)
     ,@(map (lambda (asd-file)
              `(asdf:load-asd (truename ,asd-file)))
            asd-files)
     ,@(map (lambda (system)
              `(asdf:compile-system ,system))
            systems))))

(define (test-system system asd-files test-asd-file)
  "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILES first.
Also load TEST-ASD-FILE if necessary."
  (lisp-eval-program
   `((require :asdf)
     ,@(map (lambda (asd-file)
              `(asdf:load-asd (truename ,asd-file)))
            asd-files)
     ,@(if test-asd-file
           `((asdf:load-asd (truename ,test-asd-file)))
           ;; Try some likely files.
           (map (lambda (file)
                  `(when (uiop:file-exists-p ,file)
                     (asdf:load-asd (truename ,file))))
                (list
                 (string-append system "-tests.asd")
                 (string-append system "-test.asd")
                 "tests.asd"
                 "test.asd")))
     (asdf:test-system ,system))))

(define (string->lisp-keyword . strings)
  "Return a lisp keyword for the concatenation of STRINGS."
  (string->symbol (apply string-append ":" strings)))

(define* (generate-executable-for-system type system #:key compress?)
  "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
'asdf:program-op.  The latter will always be standalone.  Depends on having
created a \"SYSTEM-exec\" system which contains the entry program."
  (lisp-eval-program
   `((require :asdf)
     ;; Only SBCL supports compression as of 2019-09-02.
     ,(if (and compress? (string=? (%lisp-type) "sbcl"))
          '(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
                      (uiop:dump-image (asdf:output-file o c)
                                       :executable t
                                       :compression t))
          '())
     (asdf:load-asd (truename ,(string-append system "-exec.asd")))
     (asdf:operate ',type ,(string-append system "-exec")))))

(define (generate-executable-wrapper-system system dependencies)
  "Generates a system which can be used by asdf to produce an image or program
inside the current directory.  The image or program will contain
DEPENDENCIES."
  (with-output-to-file (string-append system "-exec.asd")
    (lambda _
      (format #t "~y~%"
              `(defsystem ,(string->lisp-keyword system "-exec")
                 :entry-point ,(string-append system "-exec:main")
                 :depends-on (:uiop
                              ,@(map string->lisp-keyword
                                     dependencies))
                 :components ((:file ,(string-append system "-exec"))))))))

(define (generate-executable-entry-point system entry-program)
  "Generates an entry point program from the list of lisp statements
ENTRY-PROGRAM for SYSTEM within the current directory."
  (with-output-to-file (string-append system "-exec.lisp")
    (lambda _
      (let ((system (string->lisp-keyword system "-exec")))
        (format #t "~{~y~%~%~}"
                `((defpackage ,system
                    (:use :cl)
                    (:export :main))

                  (in-package ,system)

                  (defun main ()
                    (let ((arguments uiop:*command-line-arguments*))
                      (declare (ignorable arguments))
                      ,@entry-program))))))))

(define (make-asdf-configuration name conf-dir deps-conf-dir source-dir lib-dir)
  (let ((registry-dir (string-append
                       conf-dir "/source-registry.conf.d"))
        (translations-dir (string-append
                           conf-dir "/asdf-output-translations.conf.d"))
        (deps-registry-dir (string-append
                            deps-conf-dir "/source-registry.conf.d"))
        (deps-translations-dir (string-append
                                deps-conf-dir
                                "/asdf-output-translations.conf.d")))
    (mkdir-p registry-dir)
    (when (directory-exists? deps-registry-dir)
      (copy-recursively deps-registry-dir registry-dir))
    (with-output-to-file (string-append registry-dir "/50-" name ".conf")
      (lambda _
        (format #t "~y~%" `(:tree ,source-dir))))

    (mkdir-p translations-dir)
    (when (directory-exists? deps-translations-dir)
      (copy-recursively deps-translations-dir translations-dir))
    (with-output-to-file (string-append translations-dir "/50-" name ".conf")
      (lambda _
        (format #t "~y~%" `((,source-dir :**/ :*.*.*)
                            (,lib-dir :**/ :*.*.*)))))))

(define (replace-escaped-macros string)
  "Replace simple lisp forms that the guile writer escapes, for example by
replacing #{#p}# with #p.  Should only be used to replace truly simple forms
which are not nested."
  (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
                            'pre 2 'post))

(define (prepend-to-source-registry path)
  (setenv "CL_SOURCE_REGISTRY"
          (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))

(define* (build-program program outputs #:key
                        (dependency-prefixes (list (library-output outputs)))
                        (dependencies (list (basename program)))
                        entry-program
                        compress?
                        #:allow-other-keys)
  "Generate an executable program containing all DEPENDENCIES, and which will
execute ENTRY-PROGRAM.  The result is placed in PROGRAM.  When executed, it
will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
has been bound to the command-line arguments which were passed.  Link in any
asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
retained."
  (setenv "XDG_CONFIG_DIRS" (string-append (library-output outputs) "/etc"))
  (generate-executable program
                       #:dependencies dependencies
                       #:dependency-prefixes dependency-prefixes
                       #:entry-program entry-program
                       #:compress? compress?
                       #:type 'asdf:program-op)
  (let* ((name (basename program))
         (bin-directory (dirname program)))
    (with-directory-excursion bin-directory
      (rename-file (string-append name "-exec")
                   name)))
  #t)

(define* (build-image image outputs #:key
                      (dependency-prefixes (list (library-output outputs)))
                      (dependencies (list (basename image)))
                      #:allow-other-keys)
  "Generate an image, possibly standalone, which contains all DEPENDENCIES,
placing the result in IMAGE.image.  Link in any asd files from
DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
  (setenv "XDG_CONFIG_DIRS" (string-append (library-output outputs) "/etc"))
  (generate-executable image
                       #:dependencies dependencies
                       #:dependency-prefixes dependency-prefixes
                       #:entry-program '(nil)
                       #:type 'asdf:image-op)
  (let* ((name (basename image))
         (bin-directory (dirname image)))
    (with-directory-excursion bin-directory
      (rename-file (string-append name "-exec--all-systems.image")
                   (string-append name ".image"))))
  #t)

(define* (generate-executable out-file #:key
                              dependencies
                              dependency-prefixes
                              entry-program
                              type
                              compress?
                              #:allow-other-keys)
  "Generate an executable by using asdf operation TYPE, containing whithin the
image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
executable.  Link in any asd files from DEPENDENCY-PREFIXES to ensure
references to those libraries are retained."
  (let* ((bin-directory (dirname out-file))
         (name (basename out-file)))
    (mkdir-p bin-directory)
    (with-directory-excursion bin-directory
      (generate-executable-wrapper-system name dependencies)
      (generate-executable-entry-point name entry-program)
      (setenv "ASDF_OUTPUT_TRANSLATIONS"
              (replace-escaped-macros
               (format
                #f "~S"
                (wrap-output-translations
                 `(((,bin-directory :**/ :*.*.*)
                    (,bin-directory :**/ :*.*.*)))))))
      (generate-executable-for-system type name #:compress? compress?))

    (let* ((after-store-prefix-index
            (string-index out-file #\/
                          (1+ (string-length (%store-directory)))))
           (output (string-take out-file after-store-prefix-index))
           (hidden-asd-links (string-append output "/.asd-files")))

      (mkdir-p hidden-asd-links)
      (for-each
       (lambda (path)
         (for-each
          (lambda (asd-file)
            (symlink asd-file
                     (string-append hidden-asd-links
                                    "/" (basename asd-file))))
          (find-files (string-append path %source-install-prefix "/"
                                     (%lisp-type))
                      "\\.asd$")))
       dependency-prefixes))

    (delete-file (string-append bin-directory "/" name "-exec.asd"))
    (delete-file (string-append bin-directory "/" name "-exec.lisp"))
    (delete-file (string-append bin-directory "/" name "-exec.fasl"))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
;;; Copyright © 2015, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build make-bootstrap)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (guix build utils)
  #:export (copy-linux-headers
            make-stripped-libc))

;; Commentary:
;;
;; This module provides facilities to build the bootstrap binaries.
;;
;; Code:

(define (copy-linux-headers output kernel-headers)
  "Copy to OUTPUT the subset of KERNEL-HEADERS that is needed when producing a
bootstrap libc."

  (let* ((incdir (string-append output "/include")))
    (mkdir-p incdir)

    ;; Copy some of the Linux-Libre headers that glibc headers
    ;; refer to.
    (mkdir (string-append incdir "/linux"))
    (for-each (lambda (file)
                (install-file (pk 'src (string-append kernel-headers "/include/linux/" file))
                              (pk 'dest (string-append incdir "/linux"))))
              '(
                "atalk.h"               ; for 2.2.5
                "errno.h"
                "falloc.h"
                "if_addr.h"             ; for 2.16.0
                "if_ether.h"            ; for 2.2.5
                "if_link.h"             ; for 2.16.0
                "ioctl.h"
                "kernel.h"
                "limits.h"
                "neighbour.h"           ; for 2.16.0
                "netlink.h"             ; for 2.16.0
                "param.h"
                "prctl.h"               ; for 2.16.0
                "posix_types.h"
                "rtnetlink.h"           ; for 2.16.0
                "socket.h"
                "stddef.h"
                "swab.h"                ; for 2.2.5
                "sysctl.h"
                "sysinfo.h"             ; for 2.2.5
                "types.h"
                "version.h"             ; for 2.2.5
                ))

    (copy-recursively (string-append kernel-headers "/include/asm")
                      (string-append incdir "/asm"))
    (copy-recursively (string-append kernel-headers "/include/asm-generic")
                      (string-append incdir "/asm-generic"))
    (copy-recursively (string-append kernel-headers "/include/linux/byteorder")
                      (string-append incdir "/linux/byteorder"))
    #t))

(define (make-stripped-libc output libc kernel-headers)
  "Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed
when producing a bootstrap libc."

  (define (copy-mach-headers output kernel-headers)
    (let* ((incdir (string-append output "/include")))
      (copy-recursively (string-append libc "/include") incdir)

      (copy-recursively (string-append kernel-headers "/include/mach")
                        (string-append incdir "/mach"))
      #t))

  (define (copy-libc+linux-headers output kernel-headers)
    (let* ((incdir (string-append output "/include")))
      (copy-recursively (string-append libc "/include") incdir)
      (copy-linux-headers output kernel-headers)))

  (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\
util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\
_nonshared\\.a)$")

  (setvbuf (current-output-port) 'line)
  (let* ((libdir (string-append output "/lib")))
    (mkdir-p libdir)
    (for-each (lambda (file)
                (let ((target (string-append libdir "/"
                                             (basename file))))
                  (copy-file file target)
                  (remove-store-references target)))
              (find-files (string-append libc "/lib") %libc-object-files-rx))
    #t)

    (if (directory-exists? (string-append kernel-headers "/include/mach"))
        (copy-mach-headers output kernel-headers)
        (copy-libc+linux-headers output kernel-headers)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021 Julien Lepiller <julien@lepiller.eu>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build maven-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build maven pom)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            maven-build))

;; Commentary:
;;
;; Builder-side code of the standard maven build procedure.
;;
;; Code:

(define* (set-home #:key outputs inputs #:allow-other-keys)
  (let ((home (string-append (getcwd) "/build-home")))
    (setenv "HOME" home))
  (setenv "JAVA_HOME" (assoc-ref inputs "jdk"))
  #t)

(define* (configure #:key inputs #:allow-other-keys)
  (let* ((m2-files (map
                     (lambda (input)
                       (match input
                         ((name . dir)
                          (let ((m2-dir (string-append dir "/lib/m2")))
                            (if (file-exists? m2-dir) m2-dir #f)))))
                     inputs))
         (m2-files (filter (lambda (a) a) m2-files)))
    (for-each
      (lambda (m2-dir)
        (for-each
          (lambda (file)
            (let ((dir (string-append (getenv "HOME") "/.m2/repository/"
                                      (dirname file))))
              (mkdir-p dir)
              (symlink (string-append m2-dir "/" file)
                       (string-append dir "/" (basename file)))))
          (with-directory-excursion m2-dir
            (find-files "." ".*.(jar|pom)$"))))
      m2-files))
  (invoke "mvn" "-v")
  #t)

(define (fix-pom pom-file inputs local-packages excludes)
  (chmod pom-file #o644)
  (format #t "fixing ~a~%" pom-file)
  (fix-pom-dependencies pom-file (map cdr inputs)
                        #:with-plugins? #t #:with-build-dependencies? #t
                        #:with-modules? #t
                        #:local-packages local-packages
                        #:excludes excludes))

(define* (fix-pom-files #:key inputs local-packages exclude #:allow-other-keys)
  (let ((local-packages (pom-local-packages "pom.xml" #:local-packages local-packages)))
    (format (current-error-port) "Fix pom files with local packages: ~a~%" local-packages)
    (for-each
      (lambda (pom)
        (when (file-exists? pom)
          (fix-pom pom inputs local-packages exclude)))
      (pom-and-submodules "pom.xml")))
  #t)

(define* (build #:key outputs #:allow-other-keys)
  "Build the given package."
  (invoke "mvn" "package"
          ;; offline mode: don't download dependencies
          "-o"
          ;, set directory where dependencies are installed
          (string-append "-Duser.home=" (getenv "HOME")))
  #t)

(define* (check #:key tests? #:allow-other-keys)
  "Check the given package."
  (when tests?
    (invoke "mvn" "test"
            (string-append "-Duser.home=" (getenv "HOME"))
            "-e"))
  #t)

(define* (install #:key outputs #:allow-other-keys)
  "Install the given package."
  (let* ((out (assoc-ref outputs "out"))
         (java (string-append out "/lib/m2")))
    (invoke "mvn" "install" "-o" "-e"
            "-DskipTests"
            (string-append "-Duser.home=" (getenv "HOME")))
    ;; Go through the repository to find files that can be installed
    (with-directory-excursion (string-append (getenv "HOME") "/.m2/repository")
      (let ((installable
              (filter (lambda (file)
                        (not (eq? 'symlink (stat:type (lstat file)))))
                      (find-files "." "."))))
        (mkdir-p java)
        (for-each
          (lambda (file)
            (mkdir-p (string-append java "/" (dirname file)))
            (copy-file file (string-append java "/" file)))
          installable)))
    ;; Remove some files that are not required and introduce timestamps
    (for-each delete-file (find-files out "maven-metadata-local.xml"))
    (for-each delete-file (find-files out "_remote.repositories")))
  #t)

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; , `build', `check' and `install' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (add-before 'configure 'set-home set-home)
    (replace 'configure configure)
    (add-after 'configure 'fix-pom-files fix-pom-files)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)))

(define* (maven-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; maven-build-system.scm ends here