code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.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-system qt)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system cmake)
  #:use-module (guix build-system gnu)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:export (%qt-build-system-modules
            qt-build
            qt-build-system))

;; Commentary:
;;
;; This build system is an extension of the 'cmake-build-system'.  It
;; accommodates the needs of Qt and KDE applications by adding a phase run
;; after the 'install' phase:
;;
;; 'qt-wrap' phase:
;;
;; This phase looks for Qt5 plugin paths, QML paths and some XDG paths as well
;; as the corresponding environment variables.  If any of these is found in
;; the output or if respective environment variables are set, then all
;; programs in the output's "bin", "sbin", "libexec and "lib/libexec"
;; directories are wrapped in scripts defining the necessary environment
;; variables.
;;
;; Code:

(define %qt-build-system-modules
  ;; Build-side modules imported and used by default.
  `((guix build qt-build-system)
    ,@%cmake-build-system-modules))

(define (default-cmake)
  "Return the default CMake package."

  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(gnu packages cmake))))
    (module-ref module 'cmake-minimal)))

;; This barely is a copy from (guix build-system cmake), only adjusted to use
;; the variables defined here.
(define* (lower name
                #:key source inputs native-inputs outputs system target
                (cmake (default-cmake))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    `(#:source #:cmake #:inputs #:native-inputs #:outputs
      ,@(if target '() '(#:target))))

  (bag
    (name name)
    (system system)
    (target target)
    (build-inputs `(,@(if source
                          `(("source" ,source))
                          '())
                    ,@`(("cmake" ,cmake))
                    ,@native-inputs
                    ,@(if target
                          ;; Use the standard cross inputs of
                          ;; 'gnu-build-system'.
                          (standard-cross-packages target 'host)
                          '())
                    ;; Keep the standard inputs of 'gnu-build-system'.
                    ,@(standard-packages)))
    (host-inputs inputs)

    ;; The cross-libc is really a target package, but for bootstrapping
    ;; reasons, we can't put it in 'host-inputs'.  Namely, 'cross-gcc' is a
    ;; native package, so it would end up using a "native" variant of
    ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
    ;; would use a target variant (built with 'gnu-cross-build'.)
    (target-inputs (if target
                       (standard-cross-packages target 'target)
                       '()))
    (outputs outputs)
    (build (if target qt-cross-build qt-build))
    (arguments (strip-keyword-arguments private-keywords arguments))))

(define* (qt-build store name inputs
                   #:key (guile #f)
                   (outputs '("out")) (configure-flags ''())
                   (search-paths '())
                   (make-flags ''())
                   (out-of-source? #t)
                   (build-type "RelWithDebInfo")
                   (tests? #t)
                   (test-target "test")
                   (parallel-build? #t) (parallel-tests? #f)
                   (validate-runpath? #t)
                   (patch-shebangs? #t)
                   (strip-binaries? #t)
                   (strip-flags ''("--strip-debug"))
                   (strip-directories ''("lib" "lib64" "libexec"
                                         "bin" "sbin"))
                   (phases '(@ (guix build qt-build-system)
                               %standard-phases))
                   (qt-wrap-excluded-outputs ''())
                   (system (%current-system))
                   (imported-modules %qt-build-system-modules)
                   (modules '((guix build qt-build-system)
                              (guix build utils))))
  "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE
provides a 'CMakeLists.txt' file as its build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (qt-build #:source ,(match (assoc-ref inputs "source")
                                  (((? derivation? source))
                                   (derivation->output-path source))
                                  ((source)
                                   source)
                                  (source
                                   source))
                 #:system ,system
                 #:outputs %outputs
                 #:inputs %build-inputs
                 #:search-paths ',(map search-path-specification->sexp
                                       search-paths)
                 #:phases ,phases
                 #:qt-wrap-excluded-outputs ,qt-wrap-excluded-outputs
                 #:configure-flags ,configure-flags
                 #:make-flags ,make-flags
                 #:out-of-source? ,out-of-source?
                 #:build-type ,build-type
                 #:tests? ,tests?
                 #:test-target ,test-target
                 #:parallel-build? ,parallel-build?
                 #:parallel-tests? ,parallel-tests?
                 #:validate-runpath? ,validate-runpath?
                 #:patch-shebangs? ,patch-shebangs?
                 #:strip-binaries? ,strip-binaries?
                 #:strip-flags ,strip-flags
                 #:strip-directories ,strip-directories)))

  (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
                                #:system system
                                #:inputs inputs
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

;;;
;;; Cross-compilation.
;;;

(define* (qt-cross-build store name
                         #:key
                         target native-drvs target-drvs
                         (guile #f)
                         (outputs '("out"))
                         (configure-flags ''())
                         (search-paths '())
                         (native-search-paths '())
                         (make-flags ''())
                         (out-of-source? #t)
                         (build-type "RelWithDebInfo")
                         (tests? #f) ; nothing can be done
                         (test-target "test")
                         (parallel-build? #t) (parallel-tests? #f)
                         (validate-runpath? #t)
                         (patch-shebangs? #t)
                         (strip-binaries? #t)
                         (strip-flags ''("--strip-debug"
                                         "--enable-deterministic-archives"))
                         (strip-directories ''("lib" "lib64" "libexec"
                                               "bin" "sbin"))
                         (phases '(@ (guix build qt-build-system)
                                     %standard-phases))
                         (system (%current-system))
                         (build (nix-system->gnu-triplet system))
                         (imported-modules %qt-build-system-modules)
                         (modules '((guix build qt-build-system)
                                    (guix build utils))))
  "Cross-build NAME using CMAKE for TARGET, where TARGET is a GNU triplet and
with INPUTS.  This assumes that SOURCE provides a 'CMakeLists.txt' file as its
build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (let ()
         (define %build-host-inputs
           ',(map (match-lambda
                    ((name (? derivation? drv) sub ...)
                     `(,name . ,(apply derivation->output-path drv sub)))
                    ((name path)
                     `(,name . ,path)))
                  native-drvs))

         (define %build-target-inputs
           ',(map (match-lambda
                    ((name (? derivation? drv) sub ...)
                     `(,name . ,(apply derivation->output-path drv sub)))
                    ((name (? package? pkg) sub ...)
                     (let ((drv (package-cross-derivation store pkg
                                                          target system)))
                       `(,name . ,(apply derivation->output-path drv sub))))
                    ((name path)
                     `(,name . ,path)))
                  target-drvs))

         (qt-build #:source ,(match (assoc-ref native-drvs "source")
                                    (((? derivation? source))
                                     (derivation->output-path source))
                                    ((source)
                                     source)
                                    (source
                                     source))
                   #:system ,system
                   #:build ,build
                   #:target ,target
                   #:outputs %outputs
                   #:inputs %build-target-inputs
                   #:native-inputs %build-host-inputs
                   #:search-paths ',(map search-path-specification->sexp
                                         search-paths)
                   #:native-search-paths ',(map
                                            search-path-specification->sexp
                                            native-search-paths)
                   #:phases ,phases
                   #:configure-flags ,configure-flags
                   #:make-flags ,make-flags
                   #:out-of-source? ,out-of-source?
                   #:build-type ,build-type
                   #:tests? ,tests?
                   #:test-target ,test-target
                   #:parallel-build? ,parallel-build?
                   #:parallel-tests? ,parallel-tests?
                   #:validate-runpath? ,validate-runpath?
                   #:patch-shebangs? ,patch-shebangs?
                   #:strip-binaries? ,strip-binaries?
                   #:strip-flags ,strip-flags
                   #:strip-directories ,strip-directories))))

  (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
                                #:system system
                                #:inputs (append native-drvs target-drvs)
                                #:outputs outputs
                                #:modules imported-modules
                                #:guile-for-build guile-for-build))

(define qt-build-system
  (build-system
    (name 'qt)
    (description
     "The CMake build system augmented with definition of suitable environment
variables for Qt and KDE in program wrappers.")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017, 2018, 2019, 2020 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 r)
  #: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 (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (%r-build-system-modules
            r-build
            r-build-system
            cran-uri
            bioconductor-uri))

;; Commentary:
;;
;; Standard build procedure for R packages.
;;
;; Code:

(define (cran-uri name version)
  "Return a list of URI strings for the R package archive on CRAN for the
release corresponding to NAME and VERSION.  As only the most recent version is
available via the first URI, the second URI points to the archived version."
  (list (string-append "mirror://cran/src/contrib/"
                       name "_" version ".tar.gz")
        (string-append "mirror://cran/src/contrib/Archive/"
                       name "/" name "_" version ".tar.gz")))

(define* (bioconductor-uri name version #:optional type)
  "Return a URI string for the R package archive on Bioconductor for the
release corresponding to NAME and VERSION."
  (let ((type-url-part (match type
                         ('annotation "/data/annotation")
                         ('experiment "/data/experiment")
                         (_ "/bioc"))))
    (list (string-append "https://bioconductor.org/packages/release"
                         type-url-part
                         "/src/contrib/"
                         name "_" version ".tar.gz")
          ;; TODO: use %bioconductor-version from (guix import cran)
          (string-append "https://bioconductor.org/packages/3.11"
                         type-url-part
                         "/src/contrib/"
                         name "_" version ".tar.gz"))))

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

(define (default-r)
  "Return the default R package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((r-mod (resolve-interface '(gnu packages statistics))))
    (module-ref r-mod 'r-minimal)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (r (default-r))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:source #:target #:r #: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 `(("r" ,r)
                         ,@native-inputs))
         (outputs outputs)
         (build r-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (r-build store name inputs
                  #:key
                  (tests? #t)
                  (test-target "tests")
                  (configure-flags ''())
                  (phases '(@ (guix build r-build-system)
                              %standard-phases))
                  (outputs '("out"))
                  (search-paths '())
                  (system (%current-system))
                  (guile #f)
                  (substitutable? #t)
                  (imported-modules %r-build-system-modules)
                  (modules '((guix build r-build-system)
                             (guix build utils))))
  "Build SOURCE with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (r-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
                #:tests? ,tests?
                #:test-target ,test-target
                #: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
                                #:substitutable? substitutable?))

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

;;; r.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 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-system rakudo)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:export (%rakudo-build-system-modules
            rakudo-build
            rakudo-build-system))

;; Commentary:
;;
;; Standard build and install procedure for packages using the Rakudo
;; build system to be installed as system libraries.  This is
;; implemented as an extension of `gnu-build-system'.
;;
;; Code:

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

(define (default-rakudo)
  "Return the default Rakudo package."

  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(gnu packages perl6))))
    (module-ref module 'rakudo)))

(define (default-prove6)
  "Return the default perl6-tap-harness package for tests."
  (let ((module (resolve-interface '(gnu packages perl6))))
    (module-ref module 'perl6-tap-harness)))

(define (default-zef)
  "Return the default perl6-zef package."
  (let ((module (resolve-interface '(gnu packages perl6))))
    (module-ref module 'perl6-zef)))

(define* (lower name
                #:key source inputs native-inputs outputs
                system target
                (rakudo (default-rakudo))
                (prove6 (default-prove6))
                (zef (default-zef))
                (with-prove6? #t)
                (with-zef? #t)
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:source #:target #:rakudo #:prove6 #:zef #: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 `(("rakudo" ,rakudo)
                         ,@(if with-prove6?
                               `(("perl6-tap-harness" ,prove6)
                                 ,@(if with-zef?
                                       `(("perl6-zef" ,zef))
                                       '()))
                               '())
                         ,@native-inputs))
         (outputs outputs)
         (build rakudo-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (rakudo-build store name inputs
                       #:key
                       (search-paths '())
                       (tests? #t)
                       (phases '(@ (guix build rakudo-build-system)
                                   %standard-phases))
                       (outputs '("out"))
                       (system (%current-system))
                       (guile #f)
                       (with-zef? #t)
                       (with-prove6? #t)
                       (imported-modules %rakudo-build-system-modules)
                       (modules '((guix build rakudo-build-system)
                                  (guix build utils))))
  "Build SOURCE using PERL6, and with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (rakudo-build #:name ,name
                     #:source ,(match (assoc-ref inputs "source")
                                      (((? derivation? source))
                                       (derivation->output-path source))
                                      ((source)
                                       source)
                                      (source
                                        source))
                     #:search-paths ',(map search-path-specification->sexp
                                           search-paths)
                     #:phases ,phases
                     #:system ,system
                     #:tests? ,tests?
                     #:outputs %outputs
                     #: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
                                #:system system
                                #:inputs inputs
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

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

;;; rakudo.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2014, 2015 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 ruby)
  #: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 (ice-9 match)
  #:export (rubygems-uri
            %ruby-build-system-modules
            ruby-build
            ruby-build-system))

(define (rubygems-uri name version)
  "Return a URI string for the gem archive for the release corresponding to
NAME and VERSION."
  (string-append "https://rubygems.org/downloads/" name "-" version ".gem"))

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

(define (default-ruby)
  "Return the default Ruby package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((ruby (resolve-interface '(gnu packages ruby))))
    (module-ref ruby 'ruby)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (ruby (default-ruby))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:source #:target #:ruby #: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 `(("ruby" ,ruby)
                         ,@native-inputs))
         (outputs outputs)
         (build ruby-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (ruby-build store name inputs
                     #:key
                     (gem-flags ''())
                     (test-target "test")
                     (tests? #t)
                     (phases '(@ (guix build ruby-build-system)
                                 %standard-phases))
                     (outputs '("out"))
                     (search-paths '())
                     (system (%current-system))
                     (guile #f)
                     (imported-modules %ruby-build-system-modules)
                     (modules '((guix build ruby-build-system)
                                (guix build utils))))
  "Build SOURCE using RUBY and INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (ruby-build #:name ,name
                   #:source ,(match (assoc-ref inputs "source")
                               (((? derivation? source))
                                (derivation->output-path source))
                               ((source)
                                source)
                               (source
                                source))
                   #:system ,system
                   #:gem-flags ,gem-flags
                   #: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
       (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 ruby-build-system
  (build-system
    (name 'ruby)
    (description "The standard Ruby build system")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.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 scons)
  #: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 (ice-9 match)
  #:export (%scons-build-system-modules
            scons-build
            scons-build-system))

;; Commentary:
;;
;; Standard build procedure for applications using SCons. This is implemented
;; as an extension of 'gnu-build-system'.
;;
;; Code:

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

(define (default-scons)
  "Return the default SCons package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((python (resolve-interface '(gnu packages python-xyz))))
    (module-ref python 'scons)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (scons (default-scons))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:source #:target #:scons #: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 `(("scons" ,scons)
                         ,@native-inputs))
         (outputs outputs)
         (build scons-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (scons-build store name inputs
                      #:key
                      (tests? #t)
                      (scons-flags ''())
                      (build-targets ''())
                      (test-target "test")
                      (install-targets ''("install"))
                      (phases '(@ (guix build scons-build-system)
                                  %standard-phases))
                      (outputs '("out"))
                      (search-paths '())
                      (system (%current-system))
                      (guile #f)
                      (imported-modules %scons-build-system-modules)
                      (modules '((guix build scons-build-system)
                                 (guix build utils))))
  "Build SOURCE using SCons, and with INPUTS.  This assumes that SOURCE
provides a 'SConstruct' file as its build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (scons-build #:name ,name
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:scons-flags ,scons-flags
                    #:system ,system
                    #:build-targets ,build-targets
                    #:test-target ,test-target
                    #:tests? ,tests?
                    #:install-targets ,install-targets
                    #: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 scons-build-system
  (build-system
    (name 'scons)
    (description "The standard SCons build system")
    (lower lower)))

;;; scons.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; 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-system texlive)
  #: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 svn-download)
  #:use-module (ice-9 match)
  #:export (%texlive-build-system-modules
            texlive-build
            texlive-build-system
            texlive-ref
            texlive-origin
            %texlive-tag
            %texlive-revision))

;; Commentary:
;;
;; Standard build procedure for Texlive packages.
;;
;; Code:

;; These variables specify the SVN tag and the matching SVN revision.  They
;; are taken from https://www.tug.org/svn/texlive/tags/
(define %texlive-tag "texlive-2019.3")
(define %texlive-revision 51265)

(define (texlive-origin name version locations hash)
  "Return an <origin> object for a TeX Live package consisting of multiple
LOCATIONS with a provided HASH.  Use NAME and VERSION to compute a prettier
name for the checkout directory."
  (origin
    (method svn-multi-fetch)
    (uri (svn-multi-reference
          (url (string-append "svn://www.tug.org/texlive/tags/"
                              %texlive-tag "/Master/texmf-dist/"))
          (locations locations)
          (revision %texlive-revision)))
    (file-name (string-append name "-" version "-checkout"))
    (sha256 hash)))

(define (texlive-ref component id)
  "Return a <svn-reference> object for the package ID, which is part of the
given Texlive COMPONENT."
  (svn-reference
   (url (string-append "svn://www.tug.org/texlive/tags/"
                       %texlive-tag "/Master/texmf-dist/"
                       "source/" component "/" id))
   (revision %texlive-revision)))

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

(define (default-texlive-bin)
  "Return the default texlive-bin package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((tex-mod (resolve-interface '(gnu packages tex))))
    (module-ref tex-mod 'texlive-bin)))

(define (default-texlive-latex-base)
  "Return the default texlive-latex-base package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((tex-mod (resolve-interface '(gnu packages tex))))
    (module-ref tex-mod 'texlive-latex-base)))

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

  (bag
    (name name)
    (system system)
    (host-inputs `(,@(if source
                         `(("source" ,source))
                         '())
                   ,@inputs

                   ;; Keep the standard inputs of 'gnu-build-system'.
                   ,@(standard-packages)))
    (build-inputs `(("texlive-bin" ,texlive-bin)
                    ("texlive-latex-base" ,texlive-latex-base)
                    ,@native-inputs))
    (outputs outputs)
    (build texlive-build)
    (arguments (strip-keyword-arguments private-keywords arguments))))

(define* (texlive-build store name inputs
                        #:key
                        (tests? #f)
                        tex-directory
                        (build-targets #f)
                        (tex-format "luatex")
                        (phases '(@ (guix build texlive-build-system)
                                    %standard-phases))
                        (outputs '("out"))
                        (search-paths '())
                        (system (%current-system))
                        (guile #f)
                        (substitutable? #t)
                        (imported-modules %texlive-build-system-modules)
                        (modules '((guix build texlive-build-system)
                                   (guix build union)
                                   (guix build utils))))
  "Build SOURCE with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (texlive-build #:name ,name
                      #:source ,(match (assoc-ref inputs "source")
                                       (((? derivation? source))
                                        (derivation->output-path source))
                                       ((source)
                                        source)
                                       (source
                                        source))
                      #:tex-directory ,tex-directory
                      #:build-targets ,build-targets
                      #:tex-format ,tex-format
                      #:system ,system
                      #: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
                                #:substitutable? substitutable?))

(define texlive-build-system
  (build-system
    (name 'texlive)
    (description "The build system for TeX Live packages")
    (lower lower)))

;;; texlive.scm ends here


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


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>
;;;
;;; 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 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")

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

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

(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 it's 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 (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)
    (if (string-index pkgname #\-)
        (string-drop pkgname (1+ (string-index pkgname #\-)))
        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/"
                        (string-take parent-name
                                     (string-index parent-name #\-))
                        "-source")))

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

(define* (build #:key outputs inputs asd-file asd-system-name
                #:allow-other-keys)
  "Compile the system."
  (let* ((out (library-output outputs))
         (source-path (lisp-source-directory out asd-system-name))
         (translations (wrap-output-translations
                        `(,(output-translation source-path
                                               out))))
         (asd-file (source-asd-file out asd-system-name asd-file)))

    (setenv "ASDF_OUTPUT_TRANSLATIONS"
            (replace-escaped-macros (format #f "~S" translations)))

    (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache

    (compile-system asd-system-name asd-file)

    ;; As above, ecl will sometimes create this even though it doesn't use it

    (let ((cache-directory (string-append out "/.cache")))
      (when (directory-exists? cache-directory)
        (delete-file-recursively cache-directory))))
  #t)

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

(define* (create-asd-file #:key outputs
                          inputs
                          asd-file
                          asd-system-name
                          #:allow-other-keys)
  "Create a system definition file for the built system."
  (let*-values (((out) (library-output outputs))
                ((_ version) (package-name->name+version
                              (strip-store-file-name out)))
                ((new-asd-file) (string-append
                                 (library-directory out)
                                 "/" (normalize-string asd-system-name)
                                 ".asd")))

    (make-asd-file new-asd-file
                   #:system asd-system-name
                   #:version version
                   #:inputs inputs
                   #:system-asd-file asd-file))
  #t)

(define* (symlink-asd-files #:key outputs #:allow-other-keys)
  "Create an extra reference to the system in a convenient location."
  (let* ((out (library-output outputs)))
    (for-each
     (lambda (asd-file)
       (receive (new-asd-file asd-file-directory)
           (bundle-asd-file out asd-file)
         (mkdir-p asd-file-directory)
         (symlink asd-file new-asd-file)
         ;; Update the source registry for future phases which might want to
         ;; use the newly compiled system.
         (prepend-to-source-registry
          (string-append asd-file-directory "/"))))

     (find-files (string-append out %object-prefix) "\\.asd$")))
  #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)))
    (match (%lisp-type)
      ("sbcl"
       (for-each
        (lambda (file)
          (unless (string-suffix? "--system.fasl" file)
            (delete-file file)))
        (find-files out "\\.fasl$")))
      ("ecl"
       (for-each delete-file
                 (append (find-files out "\\.fas$")
                         (find-files out "\\.o$")))))

    (with-directory-excursion (library-directory out)
      (for-each
       (lambda (file)
         (rename-file file
                      (string-append "./" (basename file))))
       (find-files "."))
      (for-each delete-file-recursively
                (scandir "."
                         (lambda (file)
                           (and
                            (directory-exists? file)
                            (string<> "." file)
                            (string<> ".." file)))))))
  #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)
    (delete 'configure)
    (delete 'install)
    (replace 'build build)
    (add-before 'build 'copy-source copy-source)
    (replace 'check check)
    (replace 'strip strip)
    (add-after 'check 'create-asd-file create-asd-file)
    (add-after 'create-asd-file 'cleanup cleanup-files)
    (add-after 'cleanup 'create-symlinks symlink-asd-files)))

(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