code:
;; -*- mode: scheme; coding: utf-8 -*-
;;
;; This module was renamed from (weinholt text base64 (1 0 20100612)) to
;; (guix base64) by Nikita Karetnikov <nikita@karetnikov.org> on
;; February 12, 2014.
;;
;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015.
;; Turned into a Guile module (instead of R6RS).
;;
;; This program 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.
;;
;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; This file incorporates work covered by the following copyright and
;; permission notice:
;;
;;   Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>
;;
;;   Permission is hereby granted, free of charge, to any person obtaining a
;;   copy of this software and associated documentation files (the "Software"),
;;   to deal in the Software without restriction, including without limitation
;;   the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;   and/or sell copies of the Software, and to permit persons to whom the
;;   Software is furnished to do so, subject to the following conditions:
;;
;;   The above copyright notice and this permission notice shall be included in
;;   all copies or substantial portions of the Software.
;;
;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;   DEALINGS IN THE SOFTWARE.

;; RFC 4648 Base-N Encodings

(define-module (guix base64)
  #:export (base64-encode
            base64-decode
            base64-alphabet
            base64url-alphabet
            get-delimited-base64
            put-delimited-base64)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports))

(define-syntax define-alias
  (syntax-rules ()
    ((_ new old)
     (define-syntax new (identifier-syntax old)))))

;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
;; procedures.

(define-alias fxbit-field bit-field)
(define-alias fxarithmetic-shift ash)
(define-alias fxarithmetic-shift-left ash)
(define-alias fxand logand)
(define-alias fxior logior)
(define-alias fxxor logxor)
(define-alias fx=? =)
(define-alias fx+ +)
(define-alias mod modulo)

(define-syntax-rule (assert exp)
  (unless exp
    (throw 'assertion-failure 'exp)))

(define base64-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")

(define base64url-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")

(define base64-encode
  (case-lambda
    ;; Simple interface. Returns a string containing the canonical
    ;; base64 representation of the given bytevector.
    ((bv)
     (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
    ((bv start)
     (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
    ((bv start end)
     (base64-encode bv start end #f #f base64-alphabet #f))
    ((bv start end line-length)
     (base64-encode bv start end line-length #f base64-alphabet #f))
    ((bv start end line-length no-padding)
     (base64-encode bv start end line-length no-padding base64-alphabet #f))
    ((bv start end line-length no-padding alphabet)
     (base64-encode bv start end line-length no-padding alphabet #f))
    ;; Base64 encodes the bytes [start,end[ in the given bytevector.
    ;; Lines are limited to line-length characters (unless #f),
    ;; which must be a multiple of four. To omit the padding
    ;; characters (#\=) set no-padding to a true value. If port is
    ;; #f, returns a string.
    ((bv start end line-length no-padding alphabet port)
     (assert (or (not line-length) (zero? (mod line-length 4))))
     (let-values (((p extract) (if port
                                   (values port (lambda () (values)))
                                   (open-string-output-port))))
       (letrec ((put (if line-length
                         (let ((chars 0))
                           (lambda (p c)
                             (when (fx=? chars line-length)
                               (set! chars 0)
                               (put-char p #\linefeed))
                             (set! chars (fx+ chars 1))
                             (put-char p c)))
                         put-char)))
         (let lp ((i start))
           (cond ((= i end))
                 ((<= (+ i 3) end)
                  (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (put p (string-ref alphabet (fxbit-field x 6 12)))
                    (put p (string-ref alphabet (fxbit-field x 0 6)))
                    (lp (+ i 3))))
                 ((<= (+ i 2) end)
                  (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (put p (string-ref alphabet (fxbit-field x 6 12)))
                    (unless no-padding
                      (put p #\=))))
                 (else
                  (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (unless no-padding
                      (put p #\=)
                      (put p #\=)))))))
       (extract)))))

  ;; Decodes a base64 string. The string must contain only pure
  ;; unpadded base64 data.

(define base64-decode
  (case-lambda
    ((str)
     (base64-decode str base64-alphabet #f))
    ((str alphabet)
     (base64-decode str alphabet #f))
    ((str alphabet port)
     (unless (zero? (mod (string-length str) 4))
       (error 'base64-decode
              "input string must be a multiple of four characters"))
     (let-values (((p extract) (if port
                                   (values port (lambda () (values)))
                                   (open-bytevector-output-port))))
       (do ((i 0 (+ i 4)))
           ((= i (string-length str))
            (extract))
         (let ((c1 (string-ref str i))
               (c2 (string-ref str (+ i 1)))
               (c3 (string-ref str (+ i 2)))
               (c4 (string-ref str (+ i 3))))
           ;; TODO: be more clever than string-index
           (let ((i1 (string-index alphabet c1))
                 (i2 (string-index alphabet c2))
                 (i3 (string-index alphabet c3))
                 (i4 (string-index alphabet c4)))
             (cond ((and i1 i2 i3 i4)
                    (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                    (fxarithmetic-shift-left i2 12)
                                    (fxarithmetic-shift-left i3 6)
                                    i4)))
                      (put-u8 p (fxbit-field x 16 24))
                      (put-u8 p (fxbit-field x 8 16))
                      (put-u8 p (fxbit-field x 0 8))))
                   ((and i1 i2 i3 (char=? c4 #\=)
                         (= i (- (string-length str) 4)))
                    (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                    (fxarithmetic-shift-left i2 12)
                                    (fxarithmetic-shift-left i3 6))))
                      (put-u8 p (fxbit-field x 16 24))
                      (put-u8 p (fxbit-field x 8 16))))
                   ((and i1 i2 (char=? c3 #\=) (char=? c4 #\=)
                         (= i (- (string-length str) 4)))
                    (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                    (fxarithmetic-shift-left i2 12))))
                      (put-u8 p (fxbit-field x 16 24))))
                   (else
                    (error 'base64-decode "invalid input"
                           (list c1 c2 c3 c4)))))))))))

(define (get-line-comp f port)
  (if (port-eof? port)
      (eof-object)
      (f (get-line port))))

  ;; Reads the common -----BEGIN/END type----- delimited format from
  ;; the given port. Returns two values: a string with the type and a
  ;; bytevector containing the base64 decoded data. The second value
  ;; is the eof object if there is an eof before the BEGIN delimiter.

(define (get-delimited-base64 port)
  (define (get-first-data-line port)
    ;; Some MIME data has header fields in the same format as mail
    ;; or http. These are ignored.
    (let ((line (get-line-comp string-trim-both port)))
      (cond ((eof-object? line) line)
            ((string-index line #\:)
             (let lp ()                           ;read until empty line
               (let ((line (get-line-comp string-trim-both port)))
                 (if (string=? line "")
                     (get-line-comp string-trim-both port)
                     (lp)))))
            (else line))))
  (let ((line (get-line-comp string-trim-both port)))
    (cond ((eof-object? line)
           (values "" (eof-object)))
          ((string=? line "")
           (get-delimited-base64 port))
          ((and (string-prefix? "-----BEGIN " line)
                (string-suffix? "-----" line))
           (let* ((type (substring line 11 (- (string-length line) 5)))
                  (endline (string-append "-----END " type "-----")))
             (let-values (((outp extract) (open-bytevector-output-port)))
               (let lp ((line (get-first-data-line port)))
                 (cond ((eof-object? line)
                        (error 'get-delimited-base64
                               "unexpected end of file"))
                       ((string-prefix? "-" line)
                        (unless (string=? line endline)
                          (error 'get-delimited-base64
                                 "bad end delimiter" type line))
                        (values type (extract)))
                       (else
                        (unless (and (= (string-length line) 5)
                                     (string-prefix? "=" line)) ;Skip Radix-64 checksum
                          (base64-decode line base64-alphabet outp))
                        (lp (get-line-comp string-trim-both port))))))))
          (else     ;skip garbage (like in openssl x509 -in foo -text output).
           (get-delimited-base64 port)))))

(define put-delimited-base64
  (case-lambda
    ((port type bv line-length)
     (display (string-append "-----BEGIN " type "-----\n") port)
     (base64-encode bv 0 (bytevector-length bv)
                    line-length #f base64-alphabet port)
     (display (string-append "\n-----END " type "-----\n") port))
    ((port type bv)
     (put-delimited-base64 port type bv 76))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2020 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)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (build-system
            build-system?
            build-system-name
            build-system-description
            build-system-lower

            bag
            bag?
            bag-name
            bag-system
            bag-target
            bag-build-inputs
            bag-host-inputs
            bag-target-inputs
            bag-outputs
            bag-arguments
            bag-build

            make-bag

            build-system-with-c-toolchain))

(define-record-type* <build-system> build-system make-build-system
  build-system?
  (name        build-system-name)         ; symbol
  (description build-system-description)  ; short description
  (lower       build-system-lower))       ; args ... -> bags

;; "Bags" are low-level representations of "packages".  The system and target
;; of a bag is fixed when it's created.  This is because build systems may
;; choose inputs as a function of the system and target.
(define-record-type* <bag> bag %make-bag
  bag?
  (name          bag-name)               ;string

  (system        bag-system)             ;string
  (target        bag-target              ;string | #f
                 (default #f))

  ;; Here we use build/host/target in the sense of the GNU tool chain (info
  ;; "(autoconf) Specifying Target Triplets").
  (build-inputs  bag-build-inputs        ;list of packages
                 (default '()))
  (host-inputs   bag-host-inputs         ;list of packages
                 (default '()))

  ;; "Target inputs" are packages that are built natively, but that are used
  ;; by target programs in a cross-compilation environment.  Thus, they act
  ;; like 'inputs' as far as search paths are concerned.  The only example of
  ;; that is the cross-libc: it is an input of 'cross-gcc', thus built
  ;; natively; yet, we want it to be considered as a target input for the
  ;; purposes of $CPATH, $LIBRARY_PATH, etc.
  (target-inputs bag-target-inputs
                 (default '()))

  (outputs       bag-outputs             ;list of strings
                 (default '("out")))
  (arguments     bag-arguments           ;list
                 (default '()))
  (build         bag-build))             ;bag -> derivation

(define* (make-bag build-system name
                   #:key source (inputs '()) (native-inputs '())
                   (outputs '()) (arguments '())
                   system target)
  "Ask BUILD-SYSTEM to return a 'bag' for NAME, with the given SOURCE,
INPUTS, NATIVE-INPUTS, OUTPUTS, and additional ARGUMENTS.  If TARGET is not
#f, it must be a string with the GNU triplet of a cross-compilation target.

This is the mechanism by which a package is \"lowered\" to a bag, which is the
intermediate representation just above derivations."
  (match build-system
    (($ <build-system> _ description lower)
     (apply lower name
            #:system system
            #:source source
            #:inputs inputs
            #:native-inputs native-inputs
            #:outputs outputs
            #:target target
            arguments))))

(define (build-system-with-c-toolchain bs toolchain)
  "Return a variant of BS, a build system, that uses TOOLCHAIN instead of the
default GNU C/C++ toolchain.  TOOLCHAIN must be a list of
inputs (label/package tuples) providing equivalent functionality, such as the
'gcc-toolchain' package."
  (define lower
    (build-system-lower bs))

  (define toolchain-packages
    ;; These are the GNU toolchain packages pulled in by GNU-BUILD-SYSTEM and
    ;; all the build systems that inherit from it.  Keep the list in sync with
    ;; 'standard-packages' in (guix build-system gnu).
    '("gcc" "binutils" "libc" "libc:static" "ld-wrapper"))

  (define (lower* . args)
    (let ((lowered (apply lower args)))
      (bag
        (inherit lowered)
        (build-inputs
         (append (fold alist-delete
                       (bag-build-inputs lowered)
                       toolchain-packages)
                 toolchain)))))

  (build-system
    (inherit bs)
    (lower lower*)))

repo_name: maximed/guix

license: mit


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

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

(define* (android-ndk-build store name inputs
                      #:key
                      (tests? #t)
                      (test-target #f)
                      (phases '(@ (guix build android-ndk-build-system)
                                  %standard-phases))
                      (outputs '("out"))
                      (make-flags ''())
                      (search-paths '())
                      (system (%current-system))
                      (guile #f)
                      (imported-modules %android-ndk-build-system-modules)
                      (modules '((guix build android-ndk-build-system)
                                 (guix build utils))))
  "Build SOURCE using Android NDK, and with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (android-ndk-build #:name ,name
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:test-target ,test-target
                    #:tests? ,tests?
                    #:phases ,phases
                    #:make-flags (cons* "-f"
                                         ,(string-append
                                          (derivation->output-path
                                           (car (assoc-ref inputs "android-build")))
                                          "/share/android/build/core/main.mk")
                                         ,make-flags)
                    #: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* (lower name
                #:key source inputs native-inputs outputs system target
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."

  (define private-keywords
    '(#:source #:target #:inputs #:native-inputs #:outputs))

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

                        ;; Keep the standard inputs of 'gnu-build-system'
                        ,@(standard-packages)))
         (build-inputs `(("android-build" ,(module-ref (resolve-interface '(gnu packages android)) 'android-make-stub))
                         ("android-googletest" ,(module-ref (resolve-interface '(gnu packages android)) 'android-googletest))
                         ,@native-inputs))
         (outputs outputs)
         (build android-ndk-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define android-ndk-build-system
  (build-system
    (name 'android-ndk)
    (description
     "Android NDK build system, to build Android NDK packages")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 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 ant)
  #: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 (%ant-build-system-modules
            ant-build
            ant-build-system))

;; Commentary:
;;
;; Standard build procedure for Java packages using Ant.
;;
;; Code:

(define %ant-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build ant-build-system)
    (guix build maven java)
    (guix build maven plugin)
    (guix build maven pom)
    (guix build java-utils)
    (guix build syscalls)
    ,@%gnu-build-system-modules))

(define (default-jdk)
  "Return the default JDK package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((jdk-mod (resolve-interface '(gnu packages java))))
    (module-ref jdk-mod 'icedtea)))

(define (default-ant)
  "Return the default Ant package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((jdk-mod (resolve-interface '(gnu packages java))))
    (module-ref jdk-mod 'ant)))

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

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

(define* (ant-build store name inputs
                    #:key
                    (tests? #t)
                    (test-target "check")
                    (configure-flags ''())
                    (make-flags ''())
                    (build-target "jar")
                    (jar-name #f)
                    (main-class #f)
                    (test-include (list "**/*Test.java"))
                    (test-exclude (list "**/Abstract*.java"))
                    (source-dir "src")
                    (test-dir "src/test")
                    (phases '(@ (guix build ant-build-system)
                                %standard-phases))
                    (outputs '("out"))
                    (search-paths '())
                    (system (%current-system))
                    (guile #f)
                    (imported-modules %ant-build-system-modules)
                    (modules '((guix build ant-build-system)
                               (guix build java-utils)
                               (guix build utils))))
  "Build SOURCE with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (ant-build #:name ,name
                  #:source ,(match (assoc-ref inputs "source")
                              (((? derivation? source))
                               (derivation->output-path source))
                              ((source)
                               source)
                              (source
                               source))
                  #:make-flags ,make-flags
                  #:configure-flags ,configure-flags
                  #:system ,system
                  #:tests? ,tests?
                  #:test-target ,test-target
                  #:build-target ,build-target
                  #:jar-name ,jar-name
                  #:main-class ,main-class
                  #:test-include (list ,@test-include)
                  #:test-exclude (list ,@test-exclude)
                  #:source-dir ,source-dir
                  #:test-dir ,test-dir
                  #: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 ant-build-system
  (build-system
    (name 'ant)
    (description "The standard Ant build system")
    (lower lower)))

;;; ant.scm ends here


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

(define-module (guix build-system asdf)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module ((guix build utils)
                #:select ((package-name->name+version
                           . hyphen-separated-name->name+version)))
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (gnu packages)
  #:export (%asdf-build-system-modules
            %asdf-build-modules
            asdf-build
            asdf-build-system/sbcl
            asdf-build-system/ecl
            asdf-build-system/source
            sbcl-package->cl-source-package
            sbcl-package->ecl-package))

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

(define %asdf-build-system-modules
  ;; Imported build-side modules
  `((guix build asdf-build-system)
    (guix build lisp-utils)
    (guix build union)
    ,@%gnu-build-system-modules))

(define %asdf-build-modules
  ;; Used (visible) build-side modules
  '((guix build asdf-build-system)
    (guix build utils)
    (guix build union)
    (guix build lisp-utils)))

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

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

  (and (not target)
       (bag
         (name name)
         (system system)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs
                        ,@(standard-packages)))
         (build-inputs native-inputs)
         (outputs outputs)
         (build asdf-build/source)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (asdf-build/source store name inputs
                            #:key source outputs
                            (phases '(@ (guix build asdf-build-system)
                                        %standard-phases/source))
                            (search-paths '())
                            (system (%current-system))
                            (guile #f)
                            (imported-modules %asdf-build-system-modules)
                            (modules %asdf-build-modules))
  (define builder
    `(begin
       (use-modules ,@modules)
       (asdf-build/source #:name ,name
                          #:source ,(match (assoc-ref inputs "source")
                                      (((? derivation? source))
                                       (derivation->output-path source))
                                      ((source) source)
                                      (source source))
                          #:system ,system
                          #: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* (package-with-build-system from-build-system to-build-system
                                    from-prefix to-prefix
                                    #:key variant-property
                                    phases-transformer)
  "Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM,
and returns one using TO-BUILD-SYSTEM.  If PKG was prefixed by FROM-PREFIX,
the resulting package will be prefixed by TO-PREFIX.  Inputs of PKG are
recursively transformed using the same rule.  The result's #:phases argument
will be modified by PHASES-TRANSFORMER, an S-expression which evaluates on the
build side to a procedure of one argument.

VARIANT-PROPERTY can be added to a package's properties to indicate that the
corresponding package promise should be used as the result of this
transformation.  This allows the result to differ from what the transformation
would otherwise produce.

If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package will be
set up using CL source package conventions."
  (define target-is-source? (eq? asdf-build-system/source to-build-system))

  (define (transform-package-name name)
    (if (string-prefix? from-prefix name)
        (let ((new-name (string-drop name (string-length from-prefix))))
          (if (string-prefix? to-prefix new-name)
              new-name
              (string-append to-prefix new-name)))
        name))

  (define (has-from-build-system? pkg)
    (eq? from-build-system (package-build-system pkg)))

  (define (find-input-package pkg)
    (let* ((name (package-name pkg))
           (new-name (transform-package-name name))
           (pkgs (find-packages-by-name new-name)))
      (if (null? pkgs) #f (list-ref pkgs 0))))

  (define transform
    (mlambda (pkg)
      (define rewrite
        (match-lambda
          ((name content . rest)
           (let* ((is-package? (package? content))
                  (new-content (if is-package?
                                   (or (find-input-package content)
                                       (transform content))
                                   content)))
             `(,name ,new-content ,@rest)))))

      ;; Special considerations for source packages: CL inputs become
      ;; propagated, and un-handled arguments are removed.

      (define (new-propagated-inputs)
        (if target-is-source?
            (map rewrite
                 (append
                  (filter (match-lambda
                            ((_ input . _)
                             (has-from-build-system? input)))
                          (append (package-inputs pkg)
                                  ;; The native inputs might be needed just
                                  ;; to load the system.
                                  (package-native-inputs pkg)))
                  (package-propagated-inputs pkg)))

            (map rewrite (package-propagated-inputs pkg))))

      (define (new-inputs inputs-getter)
        (if target-is-source?
            (map rewrite
                 (filter (match-lambda
                           ((_ input . _)
                            (not (has-from-build-system? input))))
                         (inputs-getter pkg)))
            (map rewrite (inputs-getter pkg))))

      (define base-arguments
        (if target-is-source?
            (strip-keyword-arguments
             '(#:tests? #:asd-files #:lisp #:asd-systems #:test-asd-file)
             (package-arguments pkg))
            (package-arguments pkg)))

      (cond
       ((and variant-property
             (assoc-ref (package-properties pkg) variant-property))
        => force)

       ((has-from-build-system? pkg)
        (package
          (inherit pkg)
          (location (package-location pkg))
          (name (transform-package-name (package-name pkg)))
          (build-system to-build-system)
          (arguments
           (substitute-keyword-arguments base-arguments
             ((#:phases phases) (list phases-transformer phases))))
          (inputs (new-inputs package-inputs))
          (propagated-inputs (new-propagated-inputs))
          (native-inputs (append (if target-is-source?
                                     (list (list (package-name pkg) pkg))
                                     '())
                                 (new-inputs package-native-inputs)))
          (outputs (if target-is-source?
                       '("out")
                       (package-outputs pkg)))))
       (else pkg))))

  transform)

(define (strip-variant-as-necessary variant pkg)
  (define properties (package-properties pkg))
  (if (assoc variant properties)
      (package
        (inherit pkg)
        (properties (alist-delete variant properties)))
      pkg))

(define (lower lisp-type)
  (lambda* (name
            #:key source inputs outputs native-inputs system target
            (lisp (default-lisp (string->symbol lisp-type)))
            #:allow-other-keys
            #:rest arguments)
    "Return a bag for NAME"
    (define private-keywords
      '(#:target #:inputs #:native-inputs #:lisp))

    (and (not target)
         (bag
           (name name)
           (system system)
           (host-inputs `(,@(if source
                                `(("source" ,source))
                                '())
                          ,@inputs
                          ,@(standard-packages)))
           (build-inputs `((,lisp-type ,lisp)
                           ,@native-inputs))
           (outputs outputs)
           (build (asdf-build lisp-type))
           (arguments (strip-keyword-arguments private-keywords arguments))))))

(define (asdf-build lisp-type)
  (lambda* (store name inputs
                  #:key source outputs
                  (tests? #t)
                  (asd-files ''())
                  (asd-systems ''())
                  (test-asd-file #f)
                  (phases '(@ (guix build asdf-build-system)
                              %standard-phases))
                  (search-paths '())
                  (system (%current-system))
                  (guile #f)
                  (imported-modules %asdf-build-system-modules)
                  (modules %asdf-build-modules))

    (define systems
      (if (null? (cadr asd-systems))
          ;; FIXME: Find a more reliable way to get the main system name.
          (let* ((lisp-prefix (string-append lisp-type "-"))
                 (package-name (hyphen-separated-name->name+version
                                (if (string-prefix? lisp-prefix name)
                                    (string-drop name
                                                 (string-length lisp-prefix))
                                    name))))
            `(quote ,(list package-name)))
          asd-systems))

    (define builder
      `(begin
         (use-modules ,@modules)
         (parameterize ((%lisp (string-append
                                (assoc-ref %build-inputs ,lisp-type)
                                "/bin/" ,lisp-type))
                        (%lisp-type ,lisp-type))
           (asdf-build #:name ,name
                       #:source ,(match (assoc-ref inputs "source")
                                   (((? derivation? source))
                                    (derivation->output-path source))
                                   ((source) source)
                                   (source source))
                       #:asd-files ,asd-files
                       #:asd-systems ,systems
                       #:test-asd-file ,test-asd-file
                       #: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
         (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 asdf-build-system/sbcl
  (build-system
    (name 'asdf/sbcl)
    (description "The build system for ASDF binary packages using SBCL")
    (lower (lower "sbcl"))))

(define asdf-build-system/ecl
  (build-system
    (name 'asdf/ecl)
    (description "The build system for ASDF binary packages using ECL")
    (lower (lower "ecl"))))

(define asdf-build-system/source
  (build-system
    (name 'asdf/source)
    (description "The build system for ASDF source packages")
    (lower lower/source)))

(define sbcl-package->cl-source-package
  (let* ((property 'cl-source-variant)
         (transformer
          (package-with-build-system asdf-build-system/sbcl
                                     asdf-build-system/source
                                     "sbcl-"
                                     "cl-"
                                     #:variant-property property
                                     #:phases-transformer
                                     '(const %standard-phases/source))))
    (lambda (pkg)
      (transformer
       (strip-variant-as-necessary property pkg)))))

(define sbcl-package->ecl-package
  (let* ((property 'ecl-variant)
         (transformer
          (package-with-build-system asdf-build-system/sbcl
                                     asdf-build-system/ecl
                                     "sbcl-"
                                     "ecl-"
                                     #:variant-property property
                                     #:phases-transformer
                                     'identity)))
    (lambda (pkg)
      (transformer
       (strip-variant-as-necessary property pkg)))))

;;; asdf.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2021 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 cargo)
  #:use-module (guix search-paths)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%cargo-build-system-modules
            %cargo-utils-modules
            cargo-build-system
            %crate-base-url
            crate-url
            crate-url?
            crate-uri))

(define %crate-base-url
  (make-parameter "https://crates.io"))
(define crate-url
  (string-append (%crate-base-url) "/api/v1/crates/"))
(define crate-url?
  (cut string-prefix? crate-url <>))

(define (crate-uri name version)
  "Return a URI string for the crate package hosted at crates.io corresponding
to NAME and VERSION."
  (string-append crate-url name "/" version "/download"))

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

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

(define %cargo-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build cargo-build-system)
    (guix build json)
    ,@%cargo-utils-modules))

(define* (cargo-build store name inputs
                      #:key
                      (tests? #t)
                      (test-target #f)
                      (vendor-dir "guix-vendor")
                      (cargo-build-flags ''("--release"))
                      (cargo-test-flags ''("--release"))
                      (cargo-package-flags ''("--no-metadata" "--no-verify"))
                      (features ''())
                      (skip-build? #f)
                      (install-source? #t)
                      (phases '(@ (guix build cargo-build-system)
                                  %standard-phases))
                      (outputs '("out"))
                      (search-paths '())
                      (system (%current-system))
                      (guile #f)
                      (imported-modules %cargo-build-system-modules)
                      (modules '((guix build cargo-build-system)
                                 (guix build utils))))
  "Build SOURCE using CARGO, and with INPUTS."

  (define builder
    `(begin
       (use-modules ,@modules)
       (cargo-build #:name ,name
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:test-target ,test-target
                    #:vendor-dir ,vendor-dir
                    #:cargo-build-flags ,cargo-build-flags
                    #:cargo-test-flags ,cargo-test-flags
                    #:cargo-package-flags ,cargo-package-flags
                    #:features ,features
                    #:skip-build? ,skip-build?
                    #:install-source? ,install-source?
                    #:tests? ,(and tests? (not skip-build?))
                    #: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 (package-cargo-inputs p)
  (apply
    (lambda* (#:key (cargo-inputs '()) #:allow-other-keys)
      cargo-inputs)
    (package-arguments p)))

(define (package-cargo-development-inputs p)
  (apply
    (lambda* (#:key (cargo-development-inputs '()) #:allow-other-keys)
      cargo-development-inputs)
    (package-arguments p)))

(define (crate-closure inputs)
  "Return the closure of INPUTS when considering the 'cargo-inputs' and
'cargod-dev-deps' edges.  Omit duplicate inputs, except for those
already present in INPUTS itself.

This is implemented as a breadth-first traversal such that INPUTS is
preserved, and only duplicate extracted inputs are removed.

Forked from ((guix packages) transitive-inputs) since this extraction
uses slightly different rules compared to the rest of Guix (i.e. we
do not extract the conventional inputs)."
  (define (seen? seen item)
    ;; FIXME: We're using pointer identity here, which is extremely sensitive
    ;; to memoization in package-producing procedures; see
    ;; <https://bugs.gnu.org/30155>.
    (vhash-assq item seen))

  (let loop ((inputs     inputs)
             (result     '())
             (propagated '())
             (first?     #t)
             (seen       vlist-null))
    (match inputs
      (()
       (if (null? propagated)
           (reverse result)
           (loop (reverse (concatenate propagated)) result '() #f seen)))
      (((and input (label (? package? package))) rest ...)
       (if (and (not first?) (seen? seen package))
           (loop rest result propagated first? seen)
           (loop rest
                 (cons input result)
                 (cons (package-cargo-inputs package)
                       propagated)
                 first?
                 (vhash-consq package package seen))))
      ((input rest ...)
       (loop rest (cons input result) propagated first? seen)))))

(define (expand-crate-sources cargo-inputs cargo-development-inputs)
  "Extract all transitive sources for CARGO-INPUTS and CARGO-DEVELOPMENT-INPUTS
along their 'cargo-inputs' edges.

Cargo requires all transitive crate dependencies' sources to be available
in its index, even if they are optional (this is so it can generate
deterministic Cargo.lock files regardless of the target platform or enabled
features). Thus we need all transitive crate dependencies for any cargo
dev-dependencies, but this is only needed when building/testing a crate directly
(i.e. we will never need transitive dev-dependencies for any dependency crates).

Another complication arises due potential dependency cycles from Guix's
perspective: Although cargo does not permit cyclic dependencies between crates,
however, it permits cycles to occur via dev-dependencies. For example, if crate
X depends on crate Y, crate Y's tests could pull in crate X to to verify
everything builds properly (this is a rare scenario, but it it happens for
example with the `proc-macro2` and `quote` crates). This is allowed by cargo
because tests are built as a pseudo-crate which happens to depend on the
X and Y crates, forming an acyclic graph.

We can side step this problem by only considering regular cargo dependencies
since they are guaranteed to not have cycles. We can further resolve any
potential dev-dependency cycles by extracting package sources (which never have
any dependencies and thus no cycles can exist).

There are several implications of this decision:
* Building a package definition does not require actually building/checking
any dependent crates. This can be a benefits:
 - For example, sometimes a crate may have an optional dependency on some OS
 specific package which cannot be built or run on the current system. This
 approach means that the build will not fail if cargo ends up internally ignoring
 the dependency.
 - It avoids waiting for quadratic builds from source: cargo always builds
 dependencies within the current workspace. This is largely due to Rust not
 having a stable ABI and other resolutions that cargo applies. This means that
 if we have a depencency chain of X -> Y -> Z and we build each definition
 independently the following will happen:
  * Cargo will build and test crate Z
  * Cargo will build crate Z in Y's workspace, then build and test Y
  * Cargo will build crates Y and Z in X's workspace, then build and test X
* But there are also some downsides with this approach:
  - If a dependent crate is subtly broken on the system (i.e. it builds but its
  tests fail) the consuming crates may build and test successfully but
  actually fail during normal usage (however, the CI will still build all
  packages which will give visibility in case packages suddenly break).
  - Because crates aren't declared as regular inputs, other Guix facilities
  such as tracking package graphs may not work by default (however, this is
  something that can always be extended or reworked in the future)."
  (filter-map
    (match-lambda
      ((label (? package? p))
       (list label (package-source p)))
      ((label input)
       (list label input)))
    (crate-closure (append cargo-inputs cargo-development-inputs))))

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

  (define private-keywords
    '(#:source #:target #:rust #:inputs #:native-inputs #:outputs
      #:cargo-inputs #:cargo-development-inputs))

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

                        ;; Keep the standard inputs of 'gnu-build-system'
                        ,@(standard-packages)))
         (build-inputs `(("cargo" ,rust "cargo")
                         ("rustc" ,rust)
                         ,@(expand-crate-sources cargo-inputs cargo-development-inputs)
                         ,@native-inputs))
         (outputs outputs)
         (build cargo-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define cargo-build-system
  (build-system
    (name 'cargo)
    (description
     "Cargo build system, to build Rust crates")
    (lower lower)))


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

(define-module (guix build-system chicken)
  #: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 (%chicken-build-system-modules
            chicken-build
            chicken-build-system))

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

(define (default-chicken)
  ;; Lazily resolve the binding to avoid a circular dependency.
  ;; TODO is this actually needed in every build system?
  (let ((chicken (resolve-interface '(gnu packages chicken))))
      (module-ref chicken 'chicken)))

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

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

                        ;; Keep the standard inputs of 'gnu-build-system', since
                        ;; Chicken compiles Scheme by using C as an intermediate
                        ;; language.
                        ,@(standard-packages)))
         (build-inputs `(("chicken" ,chicken)
                         ,@native-inputs))
         (outputs outputs)
         (build chicken-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (chicken-build store name inputs
                   #:key
                   (phases '(@ (guix build chicken-build-system)
                               %standard-phases))
                   (outputs '("out"))
                   (search-paths '())
                   (egg-name "")
                   (unpack-path "")
                   (build-flags ''())
                   (tests? #t)
                   (system (%current-system))
                   (guile #f)
                   (imported-modules %chicken-build-system-modules)
                   (modules '((guix build chicken-build-system)
                              (guix build union)
                              (guix build utils))))
  (define builder
    `(begin
       (use-modules ,@modules)
       (chicken-build #:name ,name
                 #:source ,(match (assoc-ref inputs "source")
                             (((? derivation? source))
                              (derivation->output-path source))
                             ((source)
                              source)
                             (source
                              source))
                 #:system ,system
                 #:phases ,phases
                 #:outputs %outputs
                 #:search-paths ',(map search-path-specification->sexp
                                       search-paths)
                 #:egg-name ,egg-name
                 #:unpack-path ,unpack-path
                 #:build-flags ,build-flags
                 #:tests? ,tests?
                 #: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 chicken-build-system
  (build-system
    (name 'chicken)
    (description
     "Build system for Chicken Scheme programs")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
;;; Copyright © 2020 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 clojure)
  #:use-module (guix build clojure-utils)
  #:use-module (guix build-system)
  #:use-module (guix build-system ant)
  #:use-module ((guix build-system gnu)
                #:select (standard-packages)
                #:prefix gnu:)

  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module ((guix search-paths)
                #:select
                ((search-path-specification->sexp . search-path-spec->sexp)))
  #:use-module (guix utils)

  #:use-module (ice-9 match)
  #:export (%clojure-build-system-modules
            clojure-build
            clojure-build-system))

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

(define-with-docs %clojure-build-system-modules
  "Build-side modules imported by default."
  `((guix build clojure-build-system)
    (guix build clojure-utils)
    (guix build guile-build-system)
    ,@%ant-build-system-modules))

(define %default-modules
  ;; Modules in scope in the build-side environment.
  '((guix build clojure-build-system)
    (guix build clojure-utils)
    (guix build utils)))

(define-with-docs %default-clojure
  "The default Clojure package."
  (delay (@* (gnu packages clojure) clojure)))

(define-with-docs %default-jdk
  "The default JDK package."
  (delay (@* (gnu packages java) icedtea)))

(define-with-docs %default-zip
  "The default ZIP package."
  (delay (@* (gnu packages compression) zip)))

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

    (if target
        (error "No cross-compilation for clojure-build-system yet: LOWER"
               target) ; FIXME
        (bag (name name)
             (system system)
             (host-inputs `(,@(if source
                                  `(("source" ,source))
                                  '())
                            ,@inputs
                            ,@(gnu:standard-packages)))
             (build-inputs `(("clojure" ,clojure)
                             ("jdk" ,jdk "jdk")
                             ("zip" ,zip)
                             ,@native-inputs))
             (outputs outputs)
             (build clojure-build)
             (arguments (strip-keyword-arguments private-keywords
                                                 arguments))))))

(define-with-docs source->output-path
  "Convert source input to output path."
  (match-lambda
    (((? derivation? source))
     (derivation->output-path source))
    ((source)
     source)
    (source
     source)))

(define-with-docs maybe-guile->guile
  "Find the right guile."
  (match-lambda
    ((and maybe-guile (? package?))
     maybe-guile)
    (#f ; default
     (@* (gnu packages commencement) guile-final))))

(define* (clojure-build store name inputs
                        #:key
                        (source-dirs `',%source-dirs)
                        (test-dirs `',%test-dirs)
                        (compile-dir %compile-dir)

                        (jar-names `',(package-name->jar-names name))
                        (main-class %main-class)
                        (omit-source? %omit-source?)

                        (aot-include `',%aot-include)
                        (aot-exclude `',%aot-exclude)

                        doc-dirs ; no sensible default
                        (doc-regex %doc-regex)

                        (tests? %tests?)
                        (test-include `',%test-include)
                        (test-exclude `',%test-exclude)

                        (phases '%standard-phases)
                        (outputs '("out"))
                        (search-paths '())
                        (system (%current-system))
                        (guile #f)

                        (imported-modules %clojure-build-system-modules)
                        (modules %default-modules))
  "Build SOURCE with INPUTS."
  (let ((builder `(begin
                    (use-modules ,@modules)
                    (clojure-build #:name ,name
                                   #:source ,(source->output-path
                                              (assoc-ref inputs "source"))

                                   #:source-dirs ,source-dirs
                                   #:test-dirs ,test-dirs
                                   #:compile-dir ,compile-dir

                                   #:jar-names ,jar-names
                                   #:main-class ,main-class
                                   #:omit-source? ,omit-source?

                                   #:aot-include ,aot-include
                                   #:aot-exclude ,aot-exclude

                                   #:doc-dirs ,doc-dirs
                                   #:doc-regex ,doc-regex

                                   #:tests? ,tests?
                                   #:test-include ,test-include
                                   #:test-exclude ,test-exclude

                                   #:phases ,phases
                                   #:outputs %outputs
                                   #:search-paths ',(map search-path-spec->sexp
                                                         search-paths)
                                   #:system ,system
                                   #:inputs %build-inputs)))

        (guile-for-build (package-derivation store
                                             (maybe-guile->guile 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 clojure-build-system
  (build-system
    (name 'clojure)
    (description "Simple Clojure build system using plain old 'compile'")
    (lower lower)))

;;; clojure.scm ends here


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

(define-module (guix build-system cmake)
  #: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 (%cmake-build-system-modules
            cmake-build
            cmake-build-system))

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

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

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

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

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (cmake (default-cmake target))
                #: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 '() 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 (if target 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 cmake-cross-build cmake-build))
    (arguments (strip-keyword-arguments private-keywords arguments))))

(define* (cmake-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? #t)
                      (validate-runpath? #t)
                      (patch-shebangs? #t)
                      (strip-binaries? #t)
                      (strip-flags ''("--strip-debug"))
                      (strip-directories ''("lib" "lib64" "libexec"
                                            "bin" "sbin"))
                      (phases '(@ (guix build cmake-build-system)
                                  %standard-phases))
                      (system (%current-system))
                      (substitutable? #t)
                      (imported-modules %cmake-build-system-modules)
                      (modules '((guix build cmake-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)
       (cmake-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
                    #: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
                                #:substitutable? substitutable?
                                #:guile-for-build guile-for-build))

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

(define* (cmake-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? #t)
                            (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 cmake-build-system)
                                        %standard-phases))
                            (substitutable? #t)
                            (system (%current-system))
                            (build (nix-system->gnu-triplet system))
                            (imported-modules %cmake-build-system-modules)
                            (modules '((guix build cmake-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))

         (cmake-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
                                #:substitutable? substitutable?
                                #:guile-for-build guile-for-build))

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

;;; cmake.scm ends here


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

(define-module (guix build-system copy)
  #: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)
  #:use-module (srfi srfi-1)
  #:export (%copy-build-system-modules
            default-glibc
            lower
            copy-build
            copy-build-system))

;; Commentary:
;;
;; Standard build procedure for simple packages that don't require much
;; compilation, mostly just copying files around.  This is implemented as an
;; extension of `gnu-build-system'.
;;
;; Code:

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

(define (default-glibc)
  "Return the default glibc package."
  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(gnu packages base))))
    (module-ref module 'glibc)))

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

  (bag
    (name name)
    (system system)
    (host-inputs `(,@(if source
                         `(("source" ,source))
                         '())
                   ,@inputs
                   ;; Keep the standard inputs of 'gnu-build-system'.
                   ,@(standard-packages)))
    (build-inputs native-inputs)
    (outputs outputs)
    (build copy-build)
    (arguments (strip-keyword-arguments private-keywords arguments))))

(define* (copy-build store name inputs
                     #:key (guile #f)
                     (outputs '("out"))
                     (install-plan ''(("." "./")))
                     (search-paths '())
                     (out-of-source? #t)
                     (validate-runpath? #t)
                     (patch-shebangs? #t)
                     (strip-binaries? #t)
                     (strip-flags ''("--strip-debug"))
                     (strip-directories ''("lib" "lib64" "libexec"
                                           "bin" "sbin"))
                     (phases '(@ (guix build copy-build-system)
                                 %standard-phases))
                     (system (%current-system))
                     (imported-modules %copy-build-system-modules)
                     (modules '((guix build copy-build-system)
                                (guix build utils))))
  "Build SOURCE using INSTALL-PLAN, and with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (copy-build #:source ,(match (assoc-ref inputs "source")
                               (((?  derivation? source))
                                (derivation->output-path source))
                               ((source)
                                source)
                               (source
                                source))
                   #:system ,system
                   #:outputs %outputs
                   #:inputs %build-inputs
                   #:install-plan ,install-plan
                   #:search-paths ',(map search-path-specification->sexp
                                         search-paths)
                   #:phases ,phases
                   #:out-of-source? ,out-of-source?
                   #: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))

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

;;; copy.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016 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-system dub)
  #:use-module (guix search-paths)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (dub-build-system))

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

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

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

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

(define* (dub-build store name inputs
                      #:key
                      (tests? #t)
                      (test-target #f)
                      (dub-build-flags ''())
                      (phases '(@ (guix build dub-build-system)
                                  %standard-phases))
                      (outputs '("out"))
                      (search-paths '())
                      (system (%current-system))
                      (guile #f)
                      (imported-modules %dub-build-system-modules)
                      (modules '((guix build dub-build-system)
                                 (guix build utils))))
  "Build SOURCE using DUB, and with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (dub-build #:name ,name
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:test-target ,test-target
                    #:dub-build-flags ,dub-build-flags
                    #: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* (lower name
                #:key source inputs native-inputs outputs system target
                (ldc (default-ldc))
                (dub (default-dub))
                (pkg-config (default-pkg-config))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."

  (define private-keywords
    '(#:source #:target #:ldc #:dub #:pkg-config #:inputs #:native-inputs #:outputs))

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

                        ;; Keep the standard inputs of 'gnu-build-system'
                        ,@(standard-packages)))
         (build-inputs `(("ldc" ,ldc)
                         ("dub" ,dub)
                         ,@native-inputs))
         (outputs outputs)
         (build dub-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define dub-build-system
  (build-system
    (name 'dub)
    (description
     "DUB build system, to build D packages")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2017 Ben Woodcroft <donttrustben@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-system dune)
  #: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) #:prefix gnu:)
  #:use-module ((guix build-system ocaml) #:prefix ocaml:)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (%dune-build-system-modules
            dune-build
            dune-build-system))

;; Commentary:
;;
;; Standard build procedure for packages using dune. This is implemented as an
;; extension of `ocaml-build-system'.
;;
;; Code:

(define %dune-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build dune-build-system)
    ,@ocaml:%ocaml-build-system-modules))

(define (default-dune)
  "Return the default OCaml package."

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

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

  (and (not target)                               ;XXX: no cross-compilation
       (let ((base (ocaml:lower name
                                #:source source
                                #:inputs inputs
                                #:native-inputs native-inputs
                                #:outputs outputs
                                #:system system
                                #:target target
                                #:ocaml ocaml
                                #:findlib findlib
                                arguments)))
         (bag
           (inherit base)
           (build-inputs `(("dune" ,dune)
                           ,@(bag-build-inputs base)))
           (build dune-build)
           (arguments (strip-keyword-arguments private-keywords arguments))))))

(define* (dune-build store name inputs
                     #:key (guile #f)
                     (outputs '("out"))
                     (search-paths '())
                     (build-flags ''())
                     (out-of-source? #t)
                     (jbuild? #f)
                     (package #f)
                     (tests? #t)
                     (test-flags ''())
                     (test-target "test")
                     (install-target "install")
                     (validate-runpath? #t)
                     (patch-shebangs? #t)
                     (strip-binaries? #t)
                     (strip-flags ''("--strip-debug"))
                     (strip-directories ''("lib" "lib64" "libexec"
                                           "bin" "sbin"))
                     (phases '(@ (guix build dune-build-system)
                                 %standard-phases))
                     (system (%current-system))
                     (imported-modules %dune-build-system-modules)
                     (modules '((guix build dune-build-system)
                                (guix build utils))))
  "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE
provides a 'setup.ml' file as its build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (dune-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
                   #:test-flags ,test-flags
                   #:build-flags ,build-flags
                   #:out-of-source? ,out-of-source?
                   #:jbuild? ,jbuild?
                   #:package ,package
                   #:tests? ,tests?
                   #:test-target ,test-target
                   #:install-target ,install-target
                   #: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))

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

;;; dune.scm ends here