code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 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-system trivial)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix build-system)
  #:use-module (ice-9 match)
  #:export (trivial-build-system))

(define (guile-for-build store guile system)
  (match guile
    ((? package?)
     (package-derivation store guile system #:graft? #f))
    (#f                                         ; the default
     (let* ((distro (resolve-interface '(gnu packages commencement)))
            (guile  (module-ref distro 'guile-final)))
       (package-derivation store guile system #:graft? #f)))))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                guile builder modules allowed-references)
  "Return a bag for NAME."
  (bag
    (name name)
    (system system)
    (target target)
    (host-inputs `(,@(if source
                         `(("source" ,source))
                         '())
                   ,@inputs))
    (build-inputs native-inputs)
    (outputs outputs)
    (build (if target trivial-cross-build trivial-build))
    (arguments `(#:guile ,guile
                 #:builder ,builder
                 #:modules ,modules
                 #:allowed-references ,allowed-references))))

(define* (trivial-build store name inputs
                        #:key
                        outputs guile system builder (modules '())
                        search-paths allowed-references)
  "Run build expression BUILDER, an expression, for SYSTEM.  SOURCE is
ignored."
  (define canonicalize-reference
    (match-lambda
     ((? package? p)
      (derivation->output-path (package-derivation store p system
                                                   #:graft? #f)))
     (((? package? p) output)
      (derivation->output-path (package-derivation store p system
                                                   #:graft? #f)
                               output))
     ((? string? output)
      output)))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:outputs outputs
                                #:modules modules
                                #:allowed-references
                                (and allowed-references
                                     (map canonicalize-reference
                                          allowed-references))
                                #:guile-for-build
                                (guile-for-build store guile system)))

(define* (trivial-cross-build store name
                              #:key
                              target native-drvs target-drvs
                              outputs guile system builder (modules '())
                              search-paths native-search-paths
                              allowed-references)
  "Run build expression BUILDER, an expression, for SYSTEM.  SOURCE is
ignored."
  (define canonicalize-reference
    (match-lambda
     ((? package? p)
      (derivation->output-path (package-cross-derivation store p system)))
     (((? package? p) output)
      (derivation->output-path (package-cross-derivation store p system)
                               output))
     ((? string? output)
      output)))

  (build-expression->derivation store name builder
                                #:inputs (append native-drvs target-drvs)
                                #:system system
                                #:outputs outputs
                                #:modules modules
                                #:allowed-references
                                (and allowed-references
                                     (map canonicalize-reference
                                          allowed-references))
                                #:guile-for-build
                                (guile-for-build store guile system)))

(define trivial-build-system
  (build-system
    (name 'trivial)
    (description
     "Trivial build system, to run arbitrary Scheme build expressions")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.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-system waf)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module ((guix build-system python)
                #:select (default-python default-python2))
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (%waf-build-system-modules
            waf-build
            waf-build-system))

;; Commentary:
;;
;; Standard build procedure for applications using 'waf'.  This is very
;; similar to the 'python-build-system' and is implemented as an extension of
;; 'gnu-build-system'.
;;
;; Code:

(define %waf-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build waf-build-system)
    ,@%gnu-build-system-modules))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (python (default-python))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:source #:target #:python #:inputs #:native-inputs))

  (and (not target)                               ;XXX: no cross-compilation
       (bag
         (name name)
         (system system)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs

                        ;; Keep the standard inputs of 'gnu-build-system'.
                        ,@(standard-packages)))
         (build-inputs `(("python" ,python)
                         ,@native-inputs))
         (outputs outputs)
         (build waf-build) ; only change compared to 'lower' in python.scm
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (waf-build store name inputs
                       #:key
                       (tests? #t)
                       (test-target "check")
                       (configure-flags ''())
                       (phases '(@ (guix build waf-build-system)
                                   %standard-phases))
                       (outputs '("out"))
                       (search-paths '())
                       (system (%current-system))
                       (guile #f)
                       (imported-modules %waf-build-system-modules)
                       (modules '((guix build waf-build-system)
                                  (guix build utils))))
  "Build SOURCE with INPUTS.  This assumes that SOURCE provides a 'waf' file
as its build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (waf-build #:name ,name
                  #:source ,(match (assoc-ref inputs "source")
                              (((? derivation? source))
                               (derivation->output-path source))
                              ((source)
                               source)
                              (source
                               source))
                  #:configure-flags ,configure-flags
                  #:system ,system
                  #:test-target ,test-target
                  #:tests? ,tests?
                  #:phases ,phases
                  #:outputs %outputs
                  #:search-paths ',(map search-path-specification->sexp
                                        search-paths)
                  #:inputs %build-inputs)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define waf-build-system
  (build-system
    (name 'waf)
    (description "The standard waf build system")
    (lower lower)))

;;; waf.scm ends here

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.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 android-ndk-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            android-ndk-build))

;; Commentary:
;;
;; Builder-side code of the Android NDK build system.
;;
;; Code:

(define* (configure #:key inputs outputs #:allow-other-keys)
  (let ((library-directories (filter-map (match-lambda
                                          ((name . path)
                                           (if (eq? 'directory (stat:type (stat path)))
                                               path
                                               #f)))
                                         inputs)))
    (setenv "CC" "gcc")
    (setenv "CXX" "g++")
    (setenv "CPPFLAGS"
     (string-join
      (map (cut string-append "-I " <> "/include") library-directories)
      " "))
    (setenv "LDFLAGS"
     (string-append "-L . "
                    (string-join
                     (map (lambda (x)
                            (string-append "-L " x "/lib" " -Wl,-rpath=" x "/lib"))
                          library-directories)
                     " ")))
    #t))

(define* (install #:key inputs outputs (make-flags '()) #:allow-other-keys)
  (let ((out (assoc-ref outputs "out")))
    (apply invoke "make" "install"
           (string-append "prefix=" out)
           make-flags)
    #t))

(define* (check #:key target inputs outputs (tests? (not target)) (make-flags '()) #:allow-other-keys)
  (if tests?
      (begin
        (apply invoke "make" "check" make-flags)
        (when (and (file-exists? "tests") tests?)
          (with-directory-excursion "tests"
            (apply invoke "make" "check" make-flags))))
      (format #t "test suite not run~%"))
  #t)

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.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 android-repo)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-34)
  #:use-module (ice-9 format)
  #:export (android-repo-fetch))

;;; Commentary:
;;;
;;; This is the build-side support code of (guix android-repo-download).
;;; It allows a multirepository managed by the git-repo tool to be cloned and
;;; checked out at a specific revision.
;;;
;;; Code:

(define* (android-repo-fetch manifest-url manifest-revision directory
                             #:key (git-repo-command "git-repo"))
  "Fetch packages according to the manifest at MANIFEST-URL with
MANIFEST-REVISION.  MANIFEST-REVISION must be either a revision
or a branch.  Return #t on success, #f otherwise."

  ;; Disable TLS certificate verification.  The hash of the checkout is known
  ;; in advance anyway.
  (setenv "GIT_SSL_NO_VERIFY" "true")

  (mkdir-p directory)

  (guard (c ((invoke-error? c)
             (format (current-error-port)
                     "android-repo-fetch: '~a~{ ~a~}' failed with exit code ~a~%"
                     (invoke-error-program c)
                     (invoke-error-arguments c)
                     (or (invoke-error-exit-status c) ;XXX: not quite accurate
                         (invoke-error-stop-signal c)
                         (invoke-error-term-signal c)))
             (delete-file-recursively directory)
             #f))
    (with-directory-excursion directory
      (invoke git-repo-command "init" "-u" manifest-url "-b" manifest-revision
              "--depth=1")
      (invoke git-repo-command "sync" "-c" "--fail-fast" "-v" "-j"
              (number->string (parallel-job-count)))

      ;; Delete vendor/**/.git, system/**/.git, toolchain/**/.git,
      ;; .repo/**/.git etc since they contain timestamps.
      (for-each delete-file-recursively
       (find-files "." "^\\.git$" #:directories? #t))

      ;; Delete git state directories since they contain timestamps.
      (for-each delete-file-recursively
       (find-files ".repo" "^.*\\.git$" #:directories? #t))

      ;; This file contains timestamps.
      (delete-file ".repo/.repo_fetchtimes.json")
      #t)))

;;; android-repo.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
;;;
;;; 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 ant-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (sxml simple)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            ant-build))

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

(define* (default-build.xml jar-name prefix #:optional
                            (source-dir ".") (test-dir "./test") (main-class #f)
                            (test-include '("**/*Test.java"))
                            (test-exclude '("**/Abstract*Test.java")))
  "Create a simple build.xml with standard targets for Ant."
  (call-with-output-file "build.xml"
    (lambda (port)
      (sxml->xml
       `(project (@ (basedir ".")
                    (name ,jar-name))
                 (property (@ (name "classes.dir")
                              (value "${basedir}/build/classes")))
                 (property (@ (name "manifest.dir")
                              (value "${basedir}/build/manifest")))
                 (property (@ (name "manifest.file")
                              (value "${manifest.dir}/MANIFEST.MF")))
                 (property (@ (name "jar.dir")
                              (value "${basedir}/build/jar")))
                 (property (@ (name "dist.dir")
                              (value ,prefix)))
                 (property (@ (name "test.home")
                              (value ,test-dir)))
                 (property (@ (name "test.classes.dir")
                              (value "${basedir}/build/test-classes")))

                 ;; respect the CLASSPATH environment variable
                 (property (@ (name "build.sysclasspath")
                              (value "first")))
                 (property (@ (environment "env")))
                 (path (@ (id "classpath"))
                       (pathelement (@ (location "${env.CLASSPATH}"))))

                 (target (@ (name "manifest"))
                         (mkdir (@ (dir "${manifest.dir}")))
                         (manifest (@ (file "${manifest.file}"))
                                   ,(if main-class
                                       `(attribute (@ (name "Main-Class")
                                                      (value ,main-class)))
                                       "")))

                 (target (@ (name "compile"))
                         (mkdir (@ (dir "${classes.dir}")))
                         (javac (@ (includeantruntime "false")
                                   (srcdir ,source-dir)
                                   (destdir "${classes.dir}")
                                   (classpath (@ (refid "classpath"))))))

                 (target (@ (name "compile-tests"))
                         (mkdir (@ (dir "${test.classes.dir}")))
                         (javac (@ (includeantruntime "false")
                                   (srcdir ,test-dir)
                                   (destdir "${test.classes.dir}"))
                                (classpath
                                 (pathelement (@ (path "${env.CLASSPATH}")))
                                 (pathelement (@ (location "${classes.dir}")))
                                 (pathelement (@ (location "${test.classes.dir}"))))))

                 (target (@ (name "check")
                            (depends "compile-tests"))
                         (mkdir (@ (dir "${test.home}/test-reports")))
                         (junit (@ (printsummary "true")
                                   (showoutput "true")
                                   (fork "yes")
                                   (haltonfailure "yes"))
                                (classpath
                                 (pathelement (@ (path "${env.CLASSPATH}")))
                                 (pathelement (@ (location "${test.home}/resources")))
                                 (pathelement (@ (location "${classes.dir}")))
                                 (pathelement (@ (location "${test.classes.dir}"))))
                                (formatter (@ (type "plain")
                                              (usefile "true")))
                                (batchtest (@ (fork "yes")
                                              (todir "${test.home}/test-reports"))
                                           (fileset (@ (dir "${test.home}/java"))
                                                    ,@(map (lambda (file)
                                                            `(include (@ (name ,file))))
                                                       test-include)
                                                    ,@(map (lambda (file)
                                                            `(exclude (@ (name ,file))))
                                                       test-exclude)))))

                 (target (@ (name "jar")
                            (depends "compile, manifest"))
                         (mkdir (@ (dir "${jar.dir}")))
                         (jar (@ (destfile ,(string-append "${jar.dir}/" jar-name))
                                 (manifest "${manifest.file}")
                                 (basedir "${classes.dir}"))))

                 (target (@ (name "install"))
                         (copy (@ (todir "${dist.dir}"))
                               (fileset (@ (dir "${jar.dir}"))
                                        (include (@ (name "**/*.jar")))))))
       port)))
  (utime "build.xml" 0 0)
  #t)

(define (generate-classpath inputs)
  "Return a colon-separated string of full paths to jar files found among the
INPUTS."
  (string-join
   (apply append (map (match-lambda
                        ((_ . dir)
                         (find-files dir "\\.jar$")))
                      inputs)) ":"))

(define* (unpack #:key source #:allow-other-keys)
  "Unpack the jar archive SOURCE.  When SOURCE is not a jar archive fall back
to the default GNU unpack strategy."
  (if (string-suffix? ".jar" source)
      (begin
        (mkdir "src")
        (with-directory-excursion "src"
          (invoke "jar" "-xf" source))
        #t)
      ;; Use GNU unpack strategy for things that aren't jar archives.
      ((assq-ref gnu:%standard-phases 'unpack) #:source source)))

(define* (configure #:key inputs outputs (jar-name #f)
                    (source-dir "src")
                    (test-dir "src/test")
                    (main-class #f)
                    (test-include '("**/*Test.java"))
                    (test-exclude '("**/Abstract*.java")) #:allow-other-keys)
  (when jar-name
    (default-build.xml jar-name
                       (string-append (assoc-ref outputs "out")
                                      "/share/java")
                       source-dir test-dir main-class test-include test-exclude))
  (setenv "JAVA_HOME" (assoc-ref inputs "jdk"))
  (setenv "CLASSPATH" (generate-classpath inputs))
  #t)

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

(define (regular-jar-file-predicate file stat)
  "Predicate returning true if FILE is ending on '.jar'
and STAT indicates it is a regular file."
    (and ((file-name-predicate "\\.jar$") file stat)
         (eq? 'regular (stat:type stat))))

(define* (generate-jar-indices #:key outputs #:allow-other-keys)
  "Generate file \"META-INF/INDEX.LIST\".  This file does not use word wraps
and is preferred over \"META-INF/MANIFEST.MF\", which does use word wraps,
by Java when resolving dependencies.  So we make sure to create it so that
grafting works - and so that the garbage collector doesn't collect
dependencies of this jar file."
  (define (generate-index jar)
    (invoke "jar" "-i" jar))
  (for-each (match-lambda
              ((output . directory)
               (for-each generate-index
                         (find-files
                          directory
                          regular-jar-file-predicate))))
            outputs)
  #t)

(define* (strip-jar-timestamps #:key outputs
                               #:allow-other-keys)
  "Unpack all jar archives, reset the timestamp of all contained files, and
repack them.  This is necessary to ensure that archives are reproducible."
  (define (repack-archive jar)
    (format #t "repacking ~a\n" jar)
    (let* ((dir (mkdtemp! "jar-contents.XXXXXX"))
           (manifest (string-append dir "/META-INF/MANIFEST.MF")))
      (with-directory-excursion dir
        (invoke "jar" "xf" jar))
      (delete-file jar)
      ;; XXX: copied from (gnu build install)
      (for-each (lambda (file)
                  (let ((s (lstat file)))
                    (unless (eq? (stat:type s) 'symlink)
                      (utime file 0 0 0 0))))
                (find-files dir #:directories? #t))

      ;; The jar tool will always set the timestamp on the manifest file
      ;; and the containing directory to the current time, even when we
      ;; reuse an existing manifest file.  To avoid this we use "zip"
      ;; instead of "jar".  It is important that the manifest appears
      ;; first.
      (with-directory-excursion dir
        (let* ((files (find-files "." ".*" #:directories? #t))
               ;; To ensure that the reference scanner can detect all
               ;; store references in the jars we disable compression
               ;; with the "-0" option.
               (command (if (file-exists? manifest)
                            `("zip" "-0" "-X" ,jar ,manifest ,@files)
                            `("zip" "-0" "-X" ,jar ,@files))))
          (apply invoke command)))
      (utime jar 0 0)
      #t))

  (for-each (match-lambda
              ((output . directory)
               (for-each repack-archive
                         (find-files directory regular-jar-file-predicate))))
            outputs)
  #t)

(define* (check #:key target (make-flags '()) (tests? (not target))
                (test-target "check")
                #:allow-other-keys)
  (if tests?
      (apply invoke `("ant" ,test-target ,@make-flags))
      (format #t "test suite not run~%"))
  #t)

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

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (replace 'unpack unpack)
    (delete 'bootstrap)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)
    (add-after 'install 'reorder-jar-content
               strip-jar-timestamps)
    (add-after 'reorder-jar-content 'generate-jar-indices generate-jar-indices)
    (add-after 'generate-jar-indices 'strip-jar-timestamps
               strip-jar-timestamps)))

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2020, 2021 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 asdf-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build union)
  #:use-module (guix build lisp-utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:export (%standard-phases
            %standard-phases/source
            asdf-build
            asdf-build/source))

;; Commentary:
;;
;; System for building ASDF packages; creating executable programs and images
;; from them.
;;
;; Code:

(define %object-prefix "/lib/common-lisp")

(define (%lisp-source-install-prefix)
  (string-append %source-install-prefix "/" (%lisp-type)))

(define %system-install-prefix
  (string-append %source-install-prefix "/systems"))

(define (main-system-name output)
  ;; FIXME: Find a more reliable way to get the main system name.
  (let* ((full-name (strip-store-file-name output))
         (lisp-prefix (string-append (%lisp-type) "-"))
         (package-name (if (string-prefix? lisp-prefix full-name)
                           (string-drop full-name (string-length lisp-prefix))
                           full-name)))
    (package-name->name+version package-name)))

(define (lisp-source-directory output name)
  (string-append output (%lisp-source-install-prefix) "/" name))

(define (source-directory output name)
  (string-append output %source-install-prefix "/source/" name))

(define (library-directory output)
  (string-append output %object-prefix
                 "/" (%lisp-type)))

(define (output-translation source-path
                            object-output)
  "Return a translation for the system's source path to its binary output."
  `((,source-path
     :**/ :*.*.*)
    (,(library-directory object-output)
     :**/ :*.*.*)))

(define (source-asd-file output name asd-file)
  (string-append (lisp-source-directory output name) "/" asd-file))

(define (find-asd-files output name asd-files)
  (if (null? asd-files)
      (find-files (lisp-source-directory output name) "\\.asd$")
      (map (lambda (asd-file)
             (source-asd-file output name asd-file))
           asd-files)))

(define (copy-files-to-output out name)
  "Copy all files from the current directory to OUT.  Create an extra link to
any system-defining files in the source to a convenient location.  This is
done before any compiling so that the compiled source locations will be
valid."
  (let ((source (getcwd))
        (target (source-directory out name))
        (system-path (string-append out %system-install-prefix)))
    ;; SBCL keeps the modification time of the source file in the compiled
    ;; file, and the source files might just have been patched by a custom
    ;; phase. Therefore we reset the modification time of all the source
    ;; files before compiling.
    (for-each (lambda (file)
                (let ((s (lstat file)))
                  (unless (or (eq? (stat:type s) 'symlink)
                              (not (access? file W_OK)))
                    (utime file 0 0 0 0))))
              (find-files source #:directories? #t))
    (copy-recursively source target #:keep-mtime? #t)
    (mkdir-p system-path)
    (for-each
     (lambda (file)
       (symlink file
                (string-append system-path "/" (basename file))))
     (find-files target "\\.asd$"))
    #t))

(define* (install #:key inputs outputs #:allow-other-keys)
  "Copy and symlink all the source files.
The source files are taken from the corresponding compile package (e.g. SBCL)
if it's present in the native-inputs."
  (define output (assoc-ref outputs "out"))
  (define package-name
    (package-name->name+version
     (strip-store-file-name output)))
  (define (no-prefix pkgname)
    (let ((index (string-index pkgname #\-)))
      (if index
          (string-drop pkgname (1+ index))
          pkgname)))
  (define parent
    (match (assoc package-name inputs
                  (lambda (key alist-car)
                    (let* ((alt-key (no-prefix key))
                           (alist-car (no-prefix alist-car)))
                      (or (string=? alist-car key)
                          (string=? alist-car alt-key)))))
      (#f #f)
      (p (cdr p))))
  (define parent-name
    (and parent
         (package-name->name+version (strip-store-file-name parent))))
  (define parent-source
    (and parent
         (string-append parent "/share/common-lisp/"
                        (let ((index (string-index parent-name #\-)))
                          (if index
                              (string-take parent-name index)
                              parent-name)))))

  (define (first-subdirectory directory) ; From gnu-build-system.
    "Return the file name of the first sub-directory of DIRECTORY."
    (match (scandir directory
                    (lambda (file)
                      (and (not (member file '("." "..")))
                           (file-is-directory? (string-append directory "/"
                                                              file)))))
      ((first . _) first)))
  (define source-directory
    (if (and parent-source
             (file-exists? parent-source))
        (string-append parent-source "/" (first-subdirectory parent-source))
        "."))

  (with-directory-excursion source-directory
    (copy-files-to-output output package-name)))

(define* (copy-source #:key outputs asd-systems #:allow-other-keys)
  "Copy the source to the library output."
  (let* ((out (library-output outputs))
         (install-path (string-append out %source-install-prefix))
         (system-name (main-system-name out)))
    (copy-files-to-output out system-name)
    ;; Hide the files from asdf
    (with-directory-excursion install-path
      (rename-file "source" (%lisp-type))
      (delete-file-recursively "systems")))
  #t)

(define* (configure #:key inputs #:allow-other-keys)
  ;; Create a directory having the configuration files for
  ;; all the dependencies in 'etc/common-lisp/'.
  (let ((out (string-append (getcwd) "/.cl-union")))
    (match inputs
      (((name . directories) ...)
       (union-build out (filter directory-exists? directories)
                    #:create-all-directories? #t
                    #:log-port (%make-void-port "w"))))
    (setenv "CL_UNION" out)
    (setenv "XDG_CONFIG_DIRS" (string-append out "/etc")))
  #t)

(define* (build #:key outputs inputs asd-files asd-systems
                #:allow-other-keys)
  "Compile the system."
  (let* ((out (library-output outputs))
         (system-name (main-system-name out))
         (source-path (string-append out (%lisp-source-install-prefix)))
         (translations (wrap-output-translations
                        `(,(output-translation source-path
                                               out))))
         (asd-files (find-asd-files out system-name asd-files)))
    (setenv "ASDF_OUTPUT_TRANSLATIONS"
            (replace-escaped-macros (format #f "~S" translations)))
    (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
    (compile-systems asd-systems asd-files))
  #t)

(define* (check #:key tests? outputs inputs asd-files asd-systems
                test-asd-file
                #:allow-other-keys)
  "Test the system."
  (let* ((out (library-output outputs))
         (system-name (main-system-name out))
         (asd-files (find-asd-files out system-name asd-files))
         (test-asd-file
          (and=> test-asd-file
                 (cut source-asd-file out system-name <>))))
    (if tests?
        (test-system (first asd-systems) asd-files test-asd-file)
        (format #t "test suite not run~%")))
  #t)

(define* (create-asdf-configuration #:key inputs outputs #:allow-other-keys)
  "Create the ASDF configuration files for the built systems."
  (let* ((system-name (main-system-name (assoc-ref outputs "out")))
         (out (library-output outputs))
         (conf-dir (string-append out "/etc/common-lisp"))
         (deps-conf-dir (string-append (getenv "CL_UNION") "/etc/common-lisp"))
         (source-dir (lisp-source-directory out system-name))
         (lib-dir (string-append (library-directory out) "/" system-name)))
    (make-asdf-configuration system-name conf-dir deps-conf-dir
                             source-dir lib-dir)
    #t))

(define* (cleanup-files #:key outputs
                        #:allow-other-keys)
  "Remove any compiled files which are not a part of the final bundle."
  (let* ((out (library-output outputs))
         (cache-directory (string-append out "/.cache")))
    ;; Remove the cache directory in case the lisp implementation wrote
    ;; something in there when compiling or testing a system.
    (when (directory-exists? cache-directory)
      (delete-file-recursively cache-directory)))
  #t)

(define* (strip #:rest args)
  ;; stripping sbcl binaries removes their entry program and extra systems
  (or (string=? (%lisp-type) "sbcl")
      (apply (assoc-ref gnu:%standard-phases 'strip) args)))

(define %standard-phases/source
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'check)
    (delete 'build)
    (replace 'install install)))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (replace 'configure configure)
    (add-before 'configure 'copy-source copy-source)
    (replace 'build build)
    (replace 'check check)
    (add-after 'check 'create-asdf-configuration create-asdf-configuration)
    (add-after 'create-asdf-configuration 'cleanup cleanup-files)
    (delete 'install)
    (replace 'strip strip)))

(define* (asdf-build #:key inputs
                     (phases %standard-phases)
                     #:allow-other-keys
                     #:rest args)
  (apply gnu:gnu-build
         #:inputs inputs
         #:phases phases
         args))

(define* (asdf-build/source #:key inputs
                            (phases %standard-phases/source)
                            #:allow-other-keys
                            #:rest args)
  (apply gnu:gnu-build
         #:inputs inputs
         #:phases phases
         args))

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.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 bournish)
  #:use-module (system base language)
  #:use-module (system base compile)
  #:use-module (system repl command)
  #:use-module (system repl common)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (%bournish-language))

;;; Commentary:
;;;
;;; This is a super minimal Bourne-like shell language for Guile.  It is meant
;;; to be used at the REPL as a rescue shell.  In a way, this is to Guile what
;;; eshell is to Emacs.
;;;
;;; Code:

(define (expand-variable str)
  "Return STR or code to obtain the value of the environment variable STR
refers to."
  ;; XXX: No support for "${VAR}".
  (if (string-prefix? "$" str)
      `(or (getenv ,(string-drop str 1)) "")
      str))

(define* (display-tabulated lst
                            #:key
                            (terminal-width 80)
                            (column-gap 2))
  "Display the list of string LST in as many columns as needed given
TERMINAL-WIDTH.  Use COLUMN-GAP spaces between two subsequent columns."
  (define len (length lst))
  (define column-width
    ;; The width of a column.  Assume all the columns have the same width
    ;; (GNU ls is smarter than that.)
    (+ column-gap (reduce max 0 (map string-length lst))))
  (define columns
    (max 1
         (quotient terminal-width column-width)))
  (define pad
    (if (zero? (modulo len columns))
        0
        columns))
  (define items-per-column
    (quotient (+ len pad) columns))
  (define items (list->vector lst))

  (let loop ((indexes (unfold (cut >= <> columns)
                              (cut * <> items-per-column)
                              1+
                              0)))
    (unless (>= (first indexes) items-per-column)
      (for-each (lambda (index)
                  (let ((item (if (< index len)
                                  (vector-ref items index)
                                  "")))
                    (display (string-pad-right item column-width))))
                indexes)
      (newline)
      (loop (map 1+ indexes)))))

(define-syntax define-command-runtime
  (syntax-rules ()
    "Define run-time support of a Bournish command.  This macro ensures that
the implementation is not subject to inlining, which would prevent compiled
code from referring to it via '@@'."
    ((_ (command . args) body ...)
     (define-command-runtime command (lambda args body ...)))
    ((_ command exp)
     (begin
       (define command exp)

       ;; Prevent inlining of COMMAND.
       (set! command command)))))

(define-command-runtime ls-command-implementation
  ;; Run-time support procedure.
  (case-lambda
    (()
     (display-tabulated (scandir ".")))
    (files
     (let ((files (append-map (lambda (file)
                                (catch 'system-error
                                  (lambda ()
                                    (match (stat:type (lstat file))
                                      ('directory
                                       ;; Like GNU ls, list the contents of
                                       ;; FILE rather than FILE itself.
                                       (match (scandir file
                                                       (match-lambda
                                                         ((or "." "..") #f)
                                                         (_ #t)))
                                         (#f
                                          (list file))
                                         ((files ...)
                                          (map (cut string-append file "/" <>)
                                               files))))
                                      (_
                                       (list file))))
                                  (lambda args
                                    (let ((errno (system-error-errno args)))
                                      (format (current-error-port) "~a: ~a~%"
                                              file (strerror errno))
                                      '()))))
                              files)))
       (display-tabulated files)))))

(define (ls-command . files)
  `((@@ (guix build bournish) ls-command-implementation) ,@files))

(define (which-command program)
  `(search-path ((@@ (guix build bournish) executable-path))
                ,program))

(define (cat-command file)
  `(call-with-input-file ,file
     (lambda (port)
       ((@ (guix build utils) dump-port) port (current-output-port))
       *unspecified*)))

(define (rm-command . args)
  "Emit code for the 'rm' command."
  (cond ((member "-r" args)
         `(for-each (@ (guix build utils) delete-file-recursively)
                    (list ,@(delete "-r" args))))
        (else
         `(for-each delete-file (list ,@args)))))

(define (lines+chars port)
  "Return the number of lines and number of chars read from PORT."
  (let loop ((lines 0) (chars 0))
    (match (read-char port)
      ((? eof-object?)              ;done!
       (values lines chars))
      (#\newline                    ;recurse
       (loop (1+ lines) (1+ chars)))
      (_                            ;recurse
       (loop lines (1+ chars))))))

(define (file-exists?* file)
  "Like 'file-exists?' but emits a warning if FILE is not accessible."
  (catch 'system-error
    (lambda ()
      (stat file))
    (lambda args
      (let ((errno (system-error-errno args)))
        (format (current-error-port) "~a: ~a~%"
                file (strerror errno))
        #f))))

(define (wc-print file)
  (let-values (((lines chars)
                (call-with-input-file file lines+chars)))
              (format #t "~a ~a ~a~%" lines chars file)))

(define (wc-l-print file)
  (let-values (((lines chars)
                (call-with-input-file file lines+chars)))
              (format #t "~a ~a~%" lines file)))

(define (wc-c-print file)
  (let-values (((lines chars)
                (call-with-input-file file lines+chars)))
              (format #t "~a ~a~%" chars file)))

(define-command-runtime (wc-command-implementation . files)
  (for-each wc-print (filter file-exists?* files)))

(define-command-runtime (wc-l-command-implementation . files)
  (for-each wc-l-print (filter file-exists?* files)))

(define-command-runtime (wc-c-command-implementation . files)
  (for-each wc-c-print (filter file-exists?* files)))

(define (wc-command . args)
  "Emit code for the 'wc' command."
  (cond ((member "-l" args)
         `((@@ (guix build bournish) wc-l-command-implementation)
           ,@(delete "-l" args)))
        ((member "-c" args)
         `((@@ (guix build bournish) wc-c-command-implementation)
           ,@(delete "-c" args)))
        (else
         `((@@ (guix build bournish) wc-command-implementation) ,@args))))

(define (reboot-command . args)
  "Emit code for 'reboot'."
  ;; Normally Bournish is used in the initrd, where 'reboot' is provided
  ;; directly by (guile-user).  In other cases, just bail out.
  `(if (defined? 'reboot)
       (reboot)
       (begin
         (format (current-error-port)
                 "I don't know how to reboot, sorry about that!~%")
         #f)))

(define (help-command . _)
  (display "\
Hello, this is Bournish, a minimal Bourne-like shell in Guile!

The shell is good enough to navigate the file system and run commands but not
much beyond that.  It is meant to be used as a rescue shell in the initial RAM
disk and is probably not very useful apart from that.  It has a few built-in
commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n"))

(define %not-colon (char-set-complement (char-set #\:)))
(define (executable-path)
  "Return the search path for programs as a list."
  (match (getenv "PATH")
    (#f  '())
    (str (string-tokenize str %not-colon))))

(define %commands
  ;; Built-in commands.
  `(("echo"   ,(lambda strings `(list ,@strings)))
    ("cd"     ,(lambda (dir) `(chdir ,dir)))
    ("pwd"    ,(lambda () `(getcwd)))
    ("rm"     ,rm-command)
    ("cp"     ,(lambda (source dest) `(copy-file ,source ,dest)))
    ("help"   ,help-command)
    ("ls"     ,ls-command)
    ("which"  ,which-command)
    ("cat"    ,cat-command)
    ("wc"     ,wc-command)
    ("reboot" ,reboot-command)))

(define (read-bournish port env)
  "Read a Bournish expression from PORT, and return the corresponding Scheme
code as an sexp."
  (match (read-line port)
    ((? eof-object? eof)
     eof)
    ((= string-tokenize (command args ...))
     (match (assoc command %commands)
       ((command proc)                            ;built-in command
        (apply proc (map expand-variable args)))
       (#f
        (let ((command (if (string-prefix? "\\" command)
                           (string-drop command 1)
                           command)))
          `(system* ,command ,@(map expand-variable args))))))))

(define %bournish-language
  (let ((scheme (lookup-language 'scheme)))
    ;; XXX: The 'scheme' language lacks a "joiner", so we add one here.  This
    ;; allows us to have 'read-bournish' read one shell statement at a time
    ;; instead of having to read until EOF.
    (set! (language-joiner scheme)
      (lambda (exps env)
        (match exps
          (()   '(begin))
          ((exp) exp)
          (_    `(begin ,@exps)))))

    (make-language #:name 'bournish
                   #:title "Bournish"

                   ;; The reader does all the heavy lifting.
                   #:reader read-bournish
                   #:compilers `((scheme . ,(lambda (exp env options)
                                              (values exp env env))))
                   #:decompilers '()
                   #:evaluator (language-evaluator scheme)
                   #:printer (language-printer scheme)
                   #:make-default-environment
                   (language-make-default-environment scheme))))

;; XXX: ",L bournish" won't work unless we call our module (language bournish
;; spec), which is kinda annoying, so provide another meta-command.
(define-meta-command ((bournish guix) repl)
  "bournish
Switch to the Bournish language."
  (let ((current (repl-language repl)))
    (format #t "Welcome to ~a, a minimal Bourne-like shell!~%To switch back, type `,L ~a'.\n"
            (language-title %bournish-language)
            (language-name current))
    (current-language %bournish-language)
    (set! (repl-language repl) %bournish-language)))

;;; bournish.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@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 bzr)
  #:use-module (guix build utils)
  #:export (bzr-fetch))

;;; Commentary:
;;;
;;; This is the build-side support code of (guix bzr-download).  It allows a
;;; Bazaar repository to be branched at a specific revision.
;;;
;;; Code:

(define* (bzr-fetch url revision directory
                    #:key (bzr-command "bzr"))
  "Fetch REVISION from URL into DIRECTORY.  REVISION must be a valid Bazaar
revision identifier.  Return #t on success, else throw an exception."
  ;; Do not attempt to write .bzr.log to $HOME, which doesn't exist.
  (setenv "BZR_LOG" "/dev/null")
  ;; Disable SSL certificate verification; we rely on the hash instead.
  (invoke bzr-command "-Ossl.cert_reqs=none" "checkout"
          "--lightweight" "-r" revision url directory)
  (with-directory-excursion directory
    (begin
      (delete-file-recursively ".bzr")
      #t)))

;;; bzr.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
;;; Copyright © 2019, 2020, 2021 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020 Marius Bakke <marius@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 cargo-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build json)
  #:use-module (guix build utils)
  #:use-module (guix build cargo-utils)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            cargo-build))

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

(define (manifest-targets)
  "Extract all targets from the Cargo.toml manifest"
  (let* ((port (open-input-pipe "cargo read-manifest"))
         (data (read-json port))
         (targets (or (assoc-ref data "targets") '())))
    (close-port port)
    targets))

(define (has-executable-target?)
  "Check if the current cargo project declares any binary targets."
  (let* ((bin? (lambda (kind) (string=? kind "bin")))
         (get-kinds (lambda (dep) (assoc-ref dep "kind")))
         (bin-dep? (lambda (dep) (find bin? (get-kinds dep)))))
    (find bin-dep? (manifest-targets))))

(define (crate-src? path)
  "Check if PATH refers to a crate source, namely a gzipped tarball with a
Cargo.toml file present at its root."
    (and (not (directory-exists? path)) ; not a tarball
         ;; First we print out all file names within the tarball to see if it
         ;; looks like the source of a crate. However, the tarball will include
         ;; an extra path component which we would like to ignore (since we're
         ;; interested in checking if a Cargo.toml exists at the root of the
         ;; archive, but not nested anywhere else). We do this by cutting up
         ;; each output line and only looking at the second component. We then
         ;; check if it matches Cargo.toml exactly and short circuit if it does.
         (apply invoke (list "sh" "-c"
                             (string-append "tar -tf " path
                                            " | cut -d/ -f2"
                                            " | grep -q '^Cargo.toml$'")))))

(define* (unpack-rust-crates #:key inputs vendor-dir #:allow-other-keys)
  (define (inputs->rust-inputs inputs)
    "Filter using the label part from INPUTS."
    (filter (lambda (input)
              (match input
                ((name . _) (rust-package? name))))
            inputs))
  (define (inputs->directories inputs)
    "Extract the directory part from INPUTS."
    (match inputs
      (((names . directories) ...)
       directories)))

  (let ((rust-inputs (inputs->directories (inputs->rust-inputs inputs))))
    (unless (null? rust-inputs)
      (mkdir-p "target/package")
      (mkdir-p vendor-dir)
      ;; TODO: copy only regular inputs to target/package, not native-inputs.
      (for-each
        (lambda (input-crate)
          (for-each
            (lambda (packaged-crate)
              (unless
                (file-exists?
                  (string-append "target/package/" (basename packaged-crate)))
                (install-file packaged-crate "target/package/")))
            (find-files
              (string-append input-crate "/share/cargo/registry") "\\.crate$")))
        (delete-duplicates rust-inputs))

      (for-each (lambda (crate)
                  (invoke "tar" "xzf" crate "-C" vendor-dir))
                (find-files "target/package" "\\.crate$"))))
  #t)

(define (rust-package? name)
  (string-prefix? "rust-" name))

(define* (configure #:key inputs
                    (vendor-dir "guix-vendor")
                    #:allow-other-keys)
  "Vendor Cargo.toml dependencies as guix inputs."
  (chmod "." #o755)
  ;; Prepare one new directory with all the required dependencies.
  ;; It's necessary to do this (instead of just using /gnu/store as the
  ;; directory) because we want to hide the libraries in subdirectories
  ;; share/rust-source/... instead of polluting the user's profile root.
  (mkdir-p vendor-dir)
  (for-each
    (match-lambda
      ((name . path)
       (let* ((basepath (strip-store-file-name path))
              (crate-dir (string-append vendor-dir "/" basepath)))
         (and (crate-src? path)
              ;; Gracefully handle duplicate inputs
              (not (file-exists? crate-dir))
              (mkdir-p crate-dir)
              ;; Cargo crates are simply gzipped tarballs but with a .crate
              ;; extension. We expand the source to a directory name we control
              ;; so that we can generate any cargo checksums.
              ;; The --strip-components argument is needed to prevent creating
              ;; an extra directory within `crate-dir`.
              (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1")))))
    inputs)

  ;; Configure cargo to actually use this new directory.
  (setenv "CARGO_HOME" (string-append (getcwd) "/.cargo"))
  (mkdir-p ".cargo")
  (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8")))
    (display "
[source.crates-io]
replace-with = 'vendored-sources'

[source.vendored-sources]
directory = '" port)
    (display (string-append (getcwd) "/" vendor-dir) port)
    (display "'
" port)
    (close-port port))

  ;; Lift restriction on any lints: a crate author may have decided to opt
  ;; into stricter lints (e.g. #![deny(warnings)]) during their own builds
  ;; but we don't want any build failures that could be caused later by
  ;; upgrading the compiler for example.
  (setenv "RUSTFLAGS" "--cap-lints allow")
  (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc"))
  (setenv "LIBGIT2_SYS_USE_PKG_CONFIG" "1")
  (setenv "LIBSSH2_SYS_USE_PKG_CONFIG" "1")
  (when (assoc-ref inputs "openssl")
    (setenv "OPENSSL_DIR" (assoc-ref inputs "openssl")))
  (when (assoc-ref inputs "gettext")
    (setenv "GETTEXT_SYSTEM" (assoc-ref inputs "gettext")))
  (when (assoc-ref inputs "clang")
    (setenv "LIBCLANG_PATH"
            (string-append (assoc-ref inputs "clang") "/lib")))

  ;; We don't use the Cargo.lock file to determine the package versions we use
  ;; during building, and in any case if one is not present it is created
  ;; during the 'build phase by cargo.
  (when (file-exists? "Cargo.lock")
    (delete-file "Cargo.lock"))
  #t)

;; After the 'patch-generated-file-shebangs phase any vendored crates who have
;; their shebangs patched will have a mismatch on their checksum.
(define* (patch-cargo-checksums #:key
                                (vendor-dir "guix-vendor")
                                #:allow-other-keys)
  "Patch the checksums of the vendored crates after patching their shebangs."
  (generate-all-checksums vendor-dir)
  #t)

(define* (build #:key
                skip-build?
                (features '())
                (cargo-build-flags '("--release"))
                #:allow-other-keys)
  "Build a given Cargo package."
  (or skip-build?
      (apply invoke
             `("cargo" "build"
               ,@(if (null? features)
                     '()
                     `("--features" ,(string-join features)))
               ,@cargo-build-flags))))

(define* (check #:key
                tests?
                (cargo-test-flags '("--release"))
                #:allow-other-keys)
  "Run tests for a given Cargo package."
  (if tests?
      (apply invoke "cargo" "test" cargo-test-flags)
      #t))

(define* (package #:key
                  install-source?
                  (cargo-package-flags '("--no-metadata" "--no-verify"))
                  #:allow-other-keys)
  "Run 'cargo-package' for a given Cargo package."
  (if install-source?
    (apply invoke `("cargo" "package" ,@cargo-package-flags))
    (format #t "Not installing cargo sources, skipping `cargo package`.~%"))
  #t)

(define* (install #:key
                  inputs
                  outputs
                  skip-build?
                  install-source?
                  features
                  #:allow-other-keys)
  "Install a given Cargo package."
  (let* ((out      (assoc-ref outputs "out"))
         (registry (string-append out "/share/cargo/registry"))
         (sources  (string-append out "/share/cargo/src")))
    (mkdir-p out)

    ;; Make cargo reuse all the artifacts we just built instead
    ;; of defaulting to making a new temp directory
    (setenv "CARGO_TARGET_DIR" "./target")

    ;; Only install crates which include binary targets,
    ;; otherwise cargo will raise an error.
    (or skip-build?
        (not (has-executable-target?))
        (invoke "cargo" "install" "--no-track" "--path" "." "--root" out
                "--features" (string-join features)))

    (when install-source?
      ;; Install crate tarballs and unpacked sources for later use.
      ;; TODO: Is there a better format/directory for these files?
      (mkdir-p sources)
      (for-each (lambda (crate)
                  (install-file crate registry))
                (find-files "target/package" "\\.crate$"))

      (for-each (lambda (crate)
                  (invoke "tar" "xzf" crate "-C" sources))
                (find-files registry "\\.crate$")))

    #t))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)
    (add-after 'build 'package package)
    (add-after 'unpack 'unpack-rust-crates unpack-rust-crates)
    (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums)))

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 cargo-utils)
  #:use-module (guix build utils)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 threads)
  #:export (generate-checksums
            generate-all-checksums))

;; Commentary:
;;
;; Stand alone utilities for building Rust crates or the compiler itself,
;; without depending on the entire cargo build-system itself.
;;
;; Code:

(define (file-sha256 file-name)
  "Calculate the hexdigest of the sha256 checksum of FILE-NAME and return it."
  (let ((port (open-pipe* OPEN_READ
                          "sha256sum"
                          "--"
                          file-name)))
    (let ((result (read-delimited " " port)))
      (close-pipe port)
      result)))

(define (generate-checksums dir-name)
  "Given DIR-NAME, a store directory, checksum all the files in it one
by one and put the result into the file \".cargo-checksum.json\" in
the same directory."
  (let* ((file-names (find-files dir-name "."))
         (dir-prefix-name (string-append dir-name "/"))
         (dir-prefix-name-len (string-length dir-prefix-name))
         (checksums-file-name (string-append dir-name "/.cargo-checksum.json")))
    (call-with-output-file checksums-file-name
      (lambda (port)
        (display "{\"files\":{" port)
        (let ((sep ""))
          (for-each (lambda (file-name)
            (let ((file-relative-name (string-drop file-name dir-prefix-name-len)))
                  (display sep port)
                  (set! sep ",")
                  (write file-relative-name port)
                  (display ":" port)
                  (write (file-sha256 file-name) port))) file-names))
        ;; NB: cargo requires the "package" field in order to check if the Cargo.lock
        ;; file needs to be regenerated when the value changes. However, it doesn't
        ;; appear to care what the value is to begin with...
        (display "},\"package\":" port)
        (write (file-sha256 "/dev/null") port)
        (display "}" port)))))

(define (generate-all-checksums dir-name)
  (n-par-for-each (parallel-job-count)
    (lambda (filename)
      (let* ((dir (dirname filename))
             (checksum-file (string-append dir "/.cargo-checksum.json")))
        (when (file-exists? checksum-file) (delete-file checksum-file))
        (display (string-append
                   "patch-cargo-checksums: generate-checksums for "
                   dir "\n"))
        (generate-checksums dir)))
    (find-files dir-name "Cargo.toml$")))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 raingloom <raingloom@riseup.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 chicken-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build union)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:export (%standard-phases
            chicken-build))

;; CHICKEN_EGG_CACHE is where sources are fetched and binaries are built
;; CHICKEN_INSTALL_REPOSITORY is where dependencies are looked up
;; its first component is also where new eggs are installed.

;; TODO: deduplicate with go-build-system.scm ?
;; TODO: the binary version should be defined in one of the relevant modules
;; instead of being hardcoded everywhere. Tried to do that but got undefined
;; variable errors.

(define (chicken-package? name)
  (string-prefix? "chicken-" name))

(define* (setup-chicken-environment #:key inputs outputs #:allow-other-keys)
  (setenv "CHICKEN_INSTALL_REPOSITORY"
          (string-concatenate
           ;; see TODO item about binary version above
           (append (list (assoc-ref outputs "out") "/var/lib/chicken/11/")
                   (let ((oldenv (getenv "CHICKEN_INSTALL_REPOSITORY")))
                     (if oldenv
                         (list  ":" oldenv)
                         '())))))
  (setenv "CHICKEN_EGG_CACHE" (getcwd))
  #t)

;; This is copied from go-build-system.scm so it could probably be simplified.
;; I used it because the source of the egg needs to be unpacked into a directory
;; that is named after the egg and I knew that the go build system does that.
(define* (unpack #:key source egg-name unpack-path #:allow-other-keys)
  "Relative to $CHICKEN_EGG_CACHE, unpack SOURCE in UNPACK-PATH, or EGG-NAME
when UNPACK-PATH is unset.  If the SOURCE archive has a single top level
directory, it is stripped so that the sources appear directly under UNPACK-PATH.
When SOURCE is a directory, copy its content into UNPACK-PATH instead of
unpacking."
  (define (unpack-maybe-strip source dest)
    (let* ((scratch-dir (string-append (or (getenv "TMPDIR") "/tmp")
                                       "/scratch-dir"))
           (out (mkdir-p scratch-dir)))
      (with-directory-excursion scratch-dir
        (if (string-suffix? ".zip" source)
            (invoke "unzip" source)
            (invoke "tar" "-xvf" source))
        (let ((top-level-files (remove (lambda (x)
                                         (member x '("." "..")))
                                       (scandir "."))))
          (match top-level-files
            ((top-level-file)
             (when (file-is-directory? top-level-file)
               (copy-recursively top-level-file dest #:keep-mtime? #t)))
            (_
             (copy-recursively "." dest #:keep-mtime? #t)))))
      (delete-file-recursively scratch-dir)))

  (when (string-null? egg-name)
    (display "WARNING: The egg name is unset.\n"))
  (when (string-null? unpack-path)
    (set! unpack-path egg-name))
  (let ((dest (string-append (getenv "CHICKEN_EGG_CACHE") "/" unpack-path)))
    (mkdir-p dest)
    (if (file-is-directory? source)
        (copy-recursively source dest #:keep-mtime? #t)
        (unpack-maybe-strip source dest)))
  #t)

(define* (build #:key egg-name #:allow-other-keys)
  "Build the Chicken egg named by EGG-NAME"
  (invoke "chicken-install" "-cached" "-no-install" egg-name))

(define* (install #:key egg-name #:allow-other-keys)
  "Install the already built egg named by EGG-NAME"
  (invoke "chicken-install" "-cached" egg-name))

(define* (check #:key egg-name tests? #:allow-other-keys)
  "Build and run tests for the Chicken egg EGG-NAME"
  ;; there is no "-test-only" option, but we've already run install
  ;; so this just runs tests.
  ;; i think it's a fair assumption that phases won't be reordered.
  (setenv "CHICKEN_REPOSITORY_PATH"
          (string-append (getenv "CHICKEN_INSTALL_REPOSITORY")
                         ":"
                         (getenv "CHICKEN_REPOSITORY_PATH")))
  (when tests?
    (invoke "chicken-install" "-cached" "-test" "-no-install" egg-name)))

;; It doesn't look like Chicken generates any unnecessary references.
;; So we don't have to remove them either. Nice.

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (replace 'unpack unpack)
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'patch-generated-file-shebangs)
    (add-before 'unpack 'setup-chicken-environment setup-chicken-environment)
    (replace 'build build)
    (delete 'check)
    (replace 'install install)
    (add-after 'install 'check check)))

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; 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 clojure-build-system)
  #:use-module ((guix build ant-build-system)
                #:select ((%standard-phases . %standard-phases@ant)
                          ant-build))
  #:use-module (guix build clojure-utils)
  #:use-module (guix build java-utils)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            clojure-build))

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

(define* (build #:key
                source-dirs compile-dir
                jar-names main-class omit-source?
                aot-include aot-exclude
                #:allow-other-keys)
  "Standard 'build' phase for clojure-build-system."
  (let* ((libs (append-map find-clojure-libs source-dirs))
         (libs* (include-list\exclude-list aot-include
                                           aot-exclude
                                           #:all-list libs)))
    (mkdir-p compile-dir)
    (eval-with-clojure `(run! compile ',libs*)
                       source-dirs)
    (let ((source-dir-files-alist (map (lambda (dir)
                                         (cons dir (find-files* dir)))
                                       source-dirs))
          ;; workaround transitive compilation in Clojure
          (classes (filter (lambda (class)
                             (any (cut compiled-from? class <>)
                                  libs*))
                           (find-files* compile-dir))))
      (for-each (cut create-jar <> (cons (cons compile-dir classes)
                                         (if omit-source?
                                             '()
                                             source-dir-files-alist))
                     #:main-class main-class)
                jar-names)
      #t)))

(define* (check #:key
                test-dirs
                jar-names
                tests? test-include test-exclude
                #:allow-other-keys)
  "Standard 'check' phase for clojure-build-system.  Note that TEST-EXCLUDE has
priority over TEST-INCLUDE."
  (if tests?
      (let* ((libs (append-map find-clojure-libs test-dirs))
             (libs* (include-list\exclude-list test-include
                                               test-exclude
                                               #:all-list libs)))
        (for-each (lambda (jar)
                    (eval-with-clojure `(do (apply require
                                                   '(clojure.test ,@libs*))
                                            (apply clojure.test/run-tests
                                                   ',libs*))
                                       (cons jar test-dirs)))
                  jar-names)))
  #t)

(define-with-docs install
  "Standard 'install' phase for clojure-build-system."
  (install-jars "./"))

(define-with-docs %standard-phases
  "Standard build phases for clojure-build-system."
  (modify-phases %standard-phases@ant
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)
    (add-after 'install-license-files 'install-doc install-doc)))

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; 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 clojure-utils)
  #:use-module (guix build utils)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-8)
  #:use-module (srfi srfi-26)
  #:export (@*
            @@*
            define-with-docs

            %doc-regex
            install-doc

            %source-dirs
            %test-dirs
            %compile-dir
            package-name->jar-names
            %main-class
            %omit-source?
            %aot-include
            %aot-exclude
            %tests?
            %test-include
            %test-exclude

            %clojure-regex
            canonicalize-relative-path
            find-files*
            file-sans-extension
            relative-path->clojure-lib-string
            find-clojure-libs
            compiled-from?
            include-list\exclude-list
            eval-with-clojure
            create-jar))

(define-syntax-rule (@* module name)
  "Like (@ MODULE NAME), but resolves at run time."
  (module-ref (resolve-interface 'module) 'name))

(define-syntax-rule (@@* module name)
  "Like (@@ MODULE NAME), but resolves at run time."
  (module-ref (resolve-module 'module) 'name))

(define-syntax-rule (define-with-docs name docs val)
  "Create top-level variable named NAME with doc string DOCS and value VAL."
  (begin (define name val)
         (set-object-property! name 'documentation docs)))

(define-with-docs %doc-regex
  "Default regex for matching the base name of top-level documentation files."
  "^(README.*|.*\\.html|.*\\.org|.*\\.md|\\.markdown|\\.txt)$")

(define* (install-doc #:key
                      doc-dirs
                      (doc-regex %doc-regex)
                      outputs
                      #:allow-other-keys)
  "Install the following to the default documentation directory:

1. Top-level files with base name matching DOC-REGEX.
2. All files (recursively) inside DOC-DIRS.

DOC-REGEX can be compiled or uncompiled."
  (let* ((out (assoc-ref outputs "out"))
         (doc (assoc-ref outputs "doc"))
         (name-ver (strip-store-file-name out))
         (dest-dir (string-append (or doc out) "/share/doc/" name-ver "/"))
         (doc-regex* (if (string? doc-regex)
                         (make-regexp doc-regex)
                         doc-regex)))
    (for-each (cut install-file <> dest-dir)
              (remove (compose file-exists?
                               (cut string-append dest-dir <>))
                      (scandir "./" (cut regexp-exec doc-regex* <>))))
    (for-each (cut copy-recursively <> dest-dir)
              doc-dirs)
    #t))

(define-with-docs %source-dirs
  "A default list of source directories."
  '("src/"))

(define-with-docs %test-dirs
  "A default list of test directories."
  '("test/"))

(define-with-docs %compile-dir
  "Default directory for holding class files."
  "classes/")

(define (package-name->jar-names name)
  "Given NAME, a package name like \"foo-0.9.1b\",
return the list of default jar names: (\"foo-0.9.1b.jar\" \"foo.jar\")."
  (map (cut string-append <> ".jar")
       (list name
             (receive (base-name _)
                 (package-name->name+version name)
               base-name))))

(define-with-docs %main-class
  "Default name for main class.  It should be a symbol or #f."
  #f)

(define-with-docs %omit-source?
  "Include source in jars by default."
  #f)

(define-with-docs %aot-include
  "A default list of symbols deciding what to compile.  Note that the exclude
list has priority over the include list.  The special keyword #:all represents
all libraries found under the source directories."
  '(#:all))

(define-with-docs %aot-exclude
  "A default list of symbols deciding what not to compile.
See the doc string of '%aot-include' for more details."
  '())

(define-with-docs %tests?
  "Enable tests by default."
  #t)

(define-with-docs %test-include
  "A default list of symbols deciding what tests to include.  Note that the
exclude list has priority over the include list.  The special keyword #:all
represents all tests found under the test directories."
  '(#:all))

(define-with-docs %test-exclude
  "A default list of symbols deciding what tests to exclude.
See the doc string of '%test-include' for more details."
  '())

(define-with-docs %clojure-regex
  "Default regex for matching the base name of clojure source files."
  "\\.cljc?$")

(define-with-docs canonicalize-relative-path
  "Like 'canonicalize-path', but for relative paths.
Canonicalizations requiring the path to exist are omitted."
  (let ((remove.. (lambda (ls)
                    (fold-right (match-lambda*
                                  (((and comp (not "..")) (".." comps ...))
                                   comps)
                                  ((comp (comps ...))
                                   (cons comp comps)))
                                '()
                                ls))))
    (compose (match-lambda
               (() ".")
               (ls (string-join ls "/")))
             remove..
             (cut remove (cut member <> '("" ".")) <>)
             (cut string-split <> #\/))))

(define (find-files* base-dir . args)
  "Similar to 'find-files', but with BASE-DIR stripped and result
canonicalized."
  (map canonicalize-relative-path
       (with-directory-excursion base-dir
         (apply find-files "./" args))))

;;; FIXME: should be moved to (guix build utils)
(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 (relative-path->clojure-lib-string path)
  "Convert PATH to a clojure library string."
  (string-map (match-lambda
                (#\/ #\.)
                (#\_ #\-)
                (chr chr))
              (file-sans-extension path)))

(define* (find-clojure-libs base-dir
                            #:key (clojure-regex %clojure-regex))
  "Return the list of clojure libraries found under BASE-DIR.

CLOJURE-REGEX can be compiled or uncompiled."
  (map (compose string->symbol
                relative-path->clojure-lib-string)
       (find-files* base-dir clojure-regex)))

(define (compiled-from? class lib)
  "Given class file CLASS and clojure library symbol LIB, decide if CLASS
results from compiling LIB."
  (string-prefix? (symbol->string lib)
                  (relative-path->clojure-lib-string class)))

(define* (include-list\exclude-list include-list exclude-list
                                    #:key all-list)
  "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurrences of #:all by
slicing ALL-LIST into them and compute their list difference."
  (define (replace-#:all ls all-ls)
    (append-map (match-lambda
                  (#:all all-ls)
                  (x (list x)))
                ls))
  (let ((include-list* (replace-#:all include-list all-list))
        (exclude-list* (replace-#:all exclude-list all-list)))
    (lset-difference equal? include-list* exclude-list*)))

(define (eval-with-clojure expr extra-paths)
  "Evaluate EXPR with clojure.

EXPR must be a s-expression writable by guile and readable by clojure.
For examples, '(require '[clojure.string]) will not work,
because the guile writer converts brackets to parentheses.

EXTRA-PATHS is a list of paths which will be appended to $CLASSPATH."
  (let* ((classpath (getenv "CLASSPATH"))
         (classpath* (string-join (cons classpath extra-paths) ":")))
    (invoke "java"
            "-classpath" classpath*
            "clojure.main"
            "--eval" (object->string expr))))

(define* (create-jar output-jar dir-files-alist
                     #:key
                     (verbose? #t)
                     (compress? #f)
                     (main-class %main-class))
  "Given DIR-FILES-ALIST, an alist of the form: ((DIR . FILES) ...)
Create jar named OUTPUT-JAR from FILES with DIR stripped."
  (let ((grouped-options (string-append "c"
                                        (if verbose? "v" "")
                                        "f"
                                        (if compress? "" "0")
                                        (if main-class "e" ""))))
    (apply invoke `("jar"
                    ,grouped-options
                    ,output-jar
                    ,@(if main-class (list (symbol->string main-class)) '())
                    ,@(append-map (match-lambda
                                    ((dir . files)
                                     (append-map (lambda (file)
                                                   `("-C" ,dir ,file))
                                                 files)))
                                  dir-files-alist)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 cmake-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            cmake-build))

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

(define* (configure #:key outputs (configure-flags '()) (out-of-source? #t)
                    build-type target
                    #:allow-other-keys)
  "Configure the given package."
  (let* ((out        (assoc-ref outputs "out"))
         (abs-srcdir (getcwd))
         (srcdir     (if out-of-source?
                         (string-append "../" (basename abs-srcdir))
                         ".")))
    (format #t "source directory: ~s (relative from build: ~s)~%"
            abs-srcdir srcdir)
    (when out-of-source?
      (mkdir "../build")
      (chdir "../build"))
    (format #t "build directory: ~s~%" (getcwd))

    (let ((args `(,srcdir
                  ,@(if build-type
                        (list (string-append "-DCMAKE_BUILD_TYPE="
                                             build-type))
                        '())
                  ,(string-append "-DCMAKE_INSTALL_PREFIX=" out)
                  ;; ensure that the libraries are installed into /lib
                  "-DCMAKE_INSTALL_LIBDIR=lib"
                  ;; add input libraries to rpath
                  "-DCMAKE_INSTALL_RPATH_USE_LINK_PATH=TRUE"
                  ;; add (other) libraries of the project itself to rpath
                  ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib")
                  ;; enable verbose output from builds
                  "-DCMAKE_VERBOSE_MAKEFILE=ON"

                  ;;  Cross-build
                  ,@(if target
                        (list (string-append "-DCMAKE_C_COMPILER="
                                             target "-gcc")
                              (string-append "-DCMAKE_CXX_COMPILER="
                                             target "-g++")
                              (if (string-contains target "mingw")
                                  "-DCMAKE_SYSTEM_NAME=Windows"
                                  "-DCMAKE_SYSTEM_NAME=Linux"))
                        '())
                  ,@configure-flags)))
      (format #t "running 'cmake' with arguments ~s~%" args)
      (apply invoke "cmake" args))))

(define* (check #:key (tests? #t) (parallel-tests? #t) (test-target "test")
                #:allow-other-keys)
  (let ((gnu-check (assoc-ref gnu:%standard-phases 'check)))
    (setenv "CTEST_OUTPUT_ON_FAILURE" "1")
    (gnu-check #:tests? tests? #:test-target test-target
              #:parallel-tests? parallel-tests?)))

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; and 'check' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (replace 'check check)
    (replace 'configure configure)))

(define* (cmake-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))

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