[jackhill/guix/guix.git] / guix / import / utils.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.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 import utils)
  #:use-module (guix base32)
  #:use-module ((guix build download) #:prefix build:)
  #:use-module (gcrypt hash)
  #:use-module (guix http-client)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix discovery)
  #:use-module (guix build-system)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix download)
  #:use-module (gnu packages)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-41)
  #:export (factorize-uri

            hash-table->alist
            flatten
            assoc-ref*

            url-fetch
            guix-hash-url

            package-names->package-inputs
            maybe-inputs
            maybe-native-inputs
            package->definition

            spdx-string->license
            license->symbol

            snake-case
            beautify-description

            alist->package

            read-lines
            chunk-lines

            guix-name

            recursive-import))

(define (factorize-uri uri version)
  "Factorize URI, a package tarball URI as a string, such that any occurrences
of the string VERSION is replaced by the symbol 'version."
  (let ((version-rx (make-regexp (regexp-quote version))))
    (match (regexp-exec version-rx uri)
      (#f
       uri)
      (_
       (let ((indices (fold-matches version-rx uri
                                    '((0))
                                    (lambda (m result)
                                      (match result
                                        (((start) rest ...)
                                         `((,(match:end m))
                                           (,start . ,(match:start m))
                                           ,@rest)))))))
         (fold (lambda (index result)
                 (match index
                   ((start)
                    (cons (substring uri start)
                          result))
                   ((start . end)
                    (cons* (substring uri start end)
                           'version
                           result))))
               '()
               indices))))))

(define (hash-table->alist table)
  "Return an alist represenation of TABLE."
  (map (match-lambda
        ((key . (lst ...))
         (cons key
               (map (lambda (x)
                      (if (hash-table? x)
                          (hash-table->alist x)
                          x))
                    lst)))
        ((key . (? hash-table? table))
         (cons key (hash-table->alist table)))
        (pair pair))
       (hash-map->list cons table)))

(define (flatten lst)
  "Return a list that recursively concatenates all sub-lists of LST."
  (fold-right
   (match-lambda*
    (((sub-list ...) memo)
     (append (flatten sub-list) memo))
    ((elem memo)
     (cons elem memo)))
   '() lst))

(define (assoc-ref* alist key . rest)
  "Return the value for KEY from ALIST.  For each additional key specified,
recursively apply the procedure to the sub-list."
  (if (null? rest)
      (assoc-ref alist key)
      (apply assoc-ref* (assoc-ref alist key) rest)))

(define (url-fetch url file-name)
  "Save the contents of URL to FILE-NAME.  Return #f on failure."
  (parameterize ((current-output-port (current-error-port)))
    (build:url-fetch url file-name)))

(define (guix-hash-url filename)
  "Return the hash of FILENAME in nix-base32 format."
  (bytevector->nix-base32-string (file-sha256 filename)))

(define (spdx-string->license str)
  "Convert STR, a SPDX formatted license identifier, to a license object.
   Return #f if STR does not match any known identifiers."
  ;; https://spdx.org/licenses/
  ;; The psfl, gfl1.0, nmap, repoze
  ;; licenses doesn't have SPDX identifiers
  (match str
    ("AGPL-1.0"                    'license:agpl-1.0)
    ("AGPL-3.0"                    'license:agpl-3.0)
    ("Apache-1.1"                  'license:asl1.1)
    ("Apache-2.0"                  'license:asl2.0)
    ("BSL-1.0"                     'license:boost1.0)
    ("BSD-2-Clause-FreeBSD"        'license:bsd-2)
    ("BSD-3-Clause"                'license:bsd-3)
    ("BSD-4-Clause"                'license:bsd-4)
    ("CC0-1.0"                     'license:cc0)
    ("CC-BY-2.0"                   'license:cc-by2.0)
    ("CC-BY-3.0"                   'license:cc-by3.0)
    ("CC-BY-SA-2.0"                'license:cc-by-sa2.0)
    ("CC-BY-SA-3.0"                'license:cc-by-sa3.0)
    ("CC-BY-SA-4.0"                'license:cc-by-sa4.0)
    ("CDDL-1.0"                    'license:cddl1.0)
    ("CECILL-C"                    'license:cecill-c)
    ("Artistic-2.0"                'license:artistic2.0)
    ("ClArtistic"                  'license:clarified-artistic)
    ("CPL-1.0"                     'license:cpl1.0)
    ("EPL-1.0"                     'license:epl1.0)
    ("MIT"                         'license:expat)
    ("FTL"                         'license:freetype)
    ("GFDL-1.1"                    'license:fdl1.1+)
    ("GFDL-1.2"                    'license:fdl1.2+)
    ("GFDL-1.3"                    'license:fdl1.3+)
    ("Giftware"                    'license:giftware)
    ("GPL-1.0"                     'license:gpl1)
    ("GPL-1.0+"                    'license:gpl1+)
    ("GPL-2.0"                     'license:gpl2)
    ("GPL-2.0+"                    'license:gpl2+)
    ("GPL-3.0"                     'license:gpl3)
    ("GPL-3.0+"                    'license:gpl3+)
    ("ISC"                         'license:isc)
    ("IJG"                         'license:ijg)
    ("Imlib2"                      'license:imlib2)
    ("IPA"                         'license:ipa)
    ("IPL-1.0"                     'license:ibmpl1.0)
    ("LGPL-2.0"                    'license:lgpl2.0)
    ("LGPL-2.0+"                   'license:lgpl2.0+)
    ("LGPL-2.1"                    'license:lgpl2.1)
    ("LGPL-2.1+"                   'license:lgpl2.1+)
    ("LGPL-3.0"                    'license:lgpl3.0)
    ("LGPL-3.0+"                   'license:lgpl3.0+)
    ("MPL-1.0"                     'license:mpl1.0)
    ("MPL-1.1"                     'license:mpl1.1)
    ("MPL-2.0"                     'license:mpl2.0)
    ("MS-PL"                       'license:ms-pl)
    ("NCSA"                        'license:ncsa)
    ("OpenSSL"                     'license:openssl)
    ("OLDAP-2.8"                   'license:openldap2.8)
    ("CUA-OPL-1.0"                 'license:opl1.0)
    ("QPL-1.0"                     'license:qpl)
    ("Ruby"                        'license:ruby)
    ("SGI-B-2.0"                   'license:sgifreeb2.0)
    ("OFL-1.1"                     'license:silofl1.1)
    ("Sleepycat"                   'license:sleepycat)
    ("TCL"                         'license:tcl/tk)
    ("Unlicense"                   'license:unlicense)
    ("Vim"                         'license:vim)
    ("X11"                         'license:x11)
    ("ZPL-2.1"                     'license:zpl2.1)
    ("Zlib"                        'license:zlib)
    (_ #f)))

(define (license->symbol license)
  "Convert license to a symbol representing the variable the object is bound
to in the (guix licenses) module, or #f if there is no such known license."
  (define licenses
    (module-map (lambda (sym var) `(,(variable-ref var) . ,sym))
                (resolve-interface '(guix licenses) #:prefix 'license:)))
  (assoc-ref licenses license))

(define (snake-case str)
  "Return a downcased version of the string STR where underscores are replaced
with dashes."
  (string-join (string-split (string-downcase str) #\_) "-"))

(define (beautify-description description)
  "Improve the package DESCRIPTION by turning a beginning sentence fragment
into a proper sentence and by using two spaces between sentences."
  (let ((cleaned (if (string-prefix? "A " description)
                     (string-append "This package provides a"
                                    (substring description 1))
                     description)))
    ;; Use double spacing between sentences
    (regexp-substitute/global #f "\\. \\b"
                              cleaned 'pre ".  " 'post)))

(define* (package-names->package-inputs names #:optional (output #f))
  "Given a list of PACKAGE-NAMES, and an optional OUTPUT, tries to generate a
quoted list of inputs, as suitable to use in an 'inputs' field of a package
definition."
  (map (lambda (input)
         (cons* input (list 'unquote (string->symbol input))
                            (or (and output (list output))
                                '())))
       names))

(define* (maybe-inputs package-names #:optional (output #f))
  "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
package definition."
  (match (package-names->package-inputs package-names output)
    (()
     '())
    ((package-inputs ...)
     `((inputs (,'quasiquote ,package-inputs))))))

(define* (maybe-native-inputs package-names #:optional (output #f))
  "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
package definition."
  (match (package-names->package-inputs package-names output)
    (()
     '())
    ((package-inputs ...)
     `((native-inputs (,'quasiquote ,package-inputs))))))

(define (package->definition guix-package)
  (match guix-package
    (('package ('name (? string? name)) _ ...)
     `(define-public ,(string->symbol name)
        ,guix-package))))

(define (build-system-modules)
  (all-modules (map (lambda (entry)
                      `(,entry . "guix/build-system"))
                    %load-path)))

(define (lookup-build-system-by-name name)
  "Return a <build-system> value for the symbol NAME, representing the name of
the build system."
  (fold-module-public-variables (lambda (obj result)
                                  (if (and (build-system? obj)
                                           (eq? name (build-system-name obj)))
                                      obj result))
                                #f
                                (build-system-modules)))

(define (specs->package-lists specs)
  "Convert each string in the SPECS list to a list of a package label and a
package value."
  (map (lambda (spec)
         (let-values (((pkg out) (specification->package+output spec)))
           (match out
             ("out" (list (package-name pkg) pkg))
             (_ (list (package-name pkg) pkg out)))))
       specs))

(define (source-spec->object source)
  "Generate an <origin> object from a SOURCE specification.  The SOURCE can
either be a simple URL string, #F, or an alist containing entries for each of
the expected fields of an <origin> object."
  (match source
    ((? string? source-url)
     (let ((tarball (with-store store (download-to-store store source-url))))
       (origin
         (method url-fetch)
         (uri source-url)
         (sha256 (base32 (guix-hash-url tarball))))))
    (#f #f)
    (orig (let ((sha (match (assoc-ref orig "sha256")
                       ((("base32" . value))
                        (base32 value))
                       (_ #f))))
            (origin
              (method (match (assoc-ref orig "method")
                        ("url-fetch" (@ (guix download) url-fetch))
                        ("git-fetch" (@ (guix git-download) git-fetch))
                        ("svn-fetch" (@ (guix svn-download) svn-fetch))
                        ("hg-fetch"  (@ (guix hg-download) hg-fetch))
                        (_ #f)))
              (uri (assoc-ref orig "uri"))
              (sha256 sha))))))

(define (alist->package meta)
  (package
    (name (assoc-ref meta "name"))
    (version (assoc-ref meta "version"))
    (source (source-spec->object (assoc-ref meta "source")))
    (build-system
      (lookup-build-system-by-name
       (string->symbol (assoc-ref meta "build-system"))))
    (native-inputs
     (specs->package-lists (or (assoc-ref meta "native-inputs") '())))
    (inputs
     (specs->package-lists (or (assoc-ref meta "inputs") '())))
    (propagated-inputs
     (specs->package-lists (or (assoc-ref meta "propagated-inputs") '())))
    (home-page
     (assoc-ref meta "home-page"))
    (synopsis
     (assoc-ref meta "synopsis"))
    (description
     (assoc-ref meta "description"))
    (license
     (match (assoc-ref meta "license")
       (#f #f)
       (l
        (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:)
                        (spdx-string->license l))
            (license:fsdg-compatible l)))))))

(define* (read-lines #:optional (port (current-input-port)))
  "Read lines from PORT and return them as a list."
  (let loop ((line (read-line port))
             (lines '()))
    (if (eof-object? line)
        (reverse lines)
        (loop (read-line port)
              (cons line lines)))))

(define* (chunk-lines lines #:optional (pred string-null?))
  "Return a list of chunks, each of which is a list of lines.  The chunks are
separated by PRED."
  (let loop ((rest lines)
             (parts '()))
    (receive (before after)
        (break pred rest)
      (let ((res (cons before parts)))
        (if (null? after)
            (reverse res)
            (loop (cdr after) res))))))

(define (guix-name prefix name)
  "Return a Guix package name for a given package name."
  (string-append prefix (string-map (match-lambda
                                      (#\_ #\-)
                                      (#\. #\-)
                                      (chr (char-downcase chr)))
                                    name)))

(define* (recursive-import package-name repo
                           #:key repo->guix-package guix-name
                           #:allow-other-keys)
  "Generate a stream of package expressions for PACKAGE-NAME and all its
dependencies."
  (define (exists? dependency)
    (not (null? (find-packages-by-name (guix-name dependency)))))
  (define initial-state (list #f (list package-name) (list)))
  (define (step state)
    (match state
      ((prev (next . rest) done)
       (define (handle? dep)
         (and
           (not (equal? dep next))
           (not (member dep done))
           (not (exists? dep))))
       (receive (package . dependencies) (repo->guix-package next repo)
         (list
           (if package package '()) ;; default #f on failure would interrupt
           (if package
             (lset-union equal? rest (filter handle? (car dependencies)))
             rest)
           (cons next done))))
      ((prev '() done)
       (list #f '() done))))

  ;; Generate a lazy stream of package expressions for all unknown
  ;; dependencies in the graph.
  (stream-unfold
    ;; map: produce a stream element
    (match-lambda ((latest queue done) latest))
    ;; predicate
    (match-lambda ((latest queue done) latest))
    ;; generator: update the queue
    step
    ;; initial state
    (step initial-state)))
Commit	Line	Data
1b3e9685	1	;;; GNU Guix --- Functional package management for GNU
f54cab27	2	;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
59b20347	3	;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
11e296ef	4	;;; Copyright © 2016 David Craven <david@craven.ch>
5e892bc3	5	;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
ae9e5d66	6	;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
5b315f3e	7	;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
1b3e9685 DT	8	;;;
	9	;;; This file is part of GNU Guix.
	10	;;;
	11	;;; GNU Guix is free software; you can redistribute it and/or modify it
	12	;;; under the terms of the GNU General Public License as published by
	13	;;; the Free Software Foundation; either version 3 of the License, or (at
	14	;;; your option) any later version.
	15	;;;
	16	;;; GNU Guix is distributed in the hope that it will be useful, but
	17	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;;; GNU General Public License for more details.
	20	;;;
	21	;;; You should have received a copy of the GNU General Public License
	22	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	23
	24	(define-module (guix import utils)
140b3048	25	#:use-module (guix base32)
fbe9c101	26	#:use-module ((guix build download) #:prefix build:)
ca719424	27	#:use-module (gcrypt hash)
bb3f36ed	28	#:use-module (guix http-client)
a34b236c	29	#:use-module ((guix licenses) #:prefix license:)
1ff2619b	30	#:use-module (guix utils)
5e892bc3 RW	31	#:use-module (guix packages)
	32	#:use-module (guix discovery)
	33	#:use-module (guix build-system)
	34	#:use-module (guix gexp)
	35	#:use-module (guix store)
	36	#:use-module (guix download)
	37	#:use-module (gnu packages)
fbe9c101	38	#:use-module (ice-9 match)
6b46b04f RW	39	#:use-module (ice-9 rdelim)
6b46b04f RW	40	#:use-module (ice-9 receive)
fbe9c101	41	#:use-module (ice-9 regex)
fbe9c101	42	#:use-module (srfi srfi-1)
5e892bc3	43	#:use-module (srfi srfi-11)
ae9e5d66 OP	44	#:use-module (srfi srfi-26)
ae9e5d66 OP	45	#:use-module (srfi srfi-41)
1ff2619b EB	46	#:export (factorize-uri
	47
	48	hash-table->alist
	49	flatten
	50	assoc-ref*
	51
140b3048 DT	52	url-fetch
	53	guix-hash-url
	54
5a9ef8a9	55	package-names->package-inputs
bb3f36ed DC	56	maybe-inputs
	57	maybe-native-inputs
	58	package->definition
	59
59b20347	60	spdx-string->license
140b3048 DT	61	license->symbol
140b3048 DT	62
2028a2c9	63	snake-case
5e892bc3 RW	64	beautify-description
5e892bc3 RW	65
6b46b04f RW	66	alist->package
	67
	68	read-lines
ae9e5d66 OP	69	chunk-lines
	70
	71	guix-name
	72
	73	recursive-import))
1b3e9685 DT	74
	75	(define (factorize-uri uri version)
	76	"Factorize URI, a package tarball URI as a string, such that any occurrences
	77	of the string VERSION is replaced by the symbol 'version."
	78	(let ((version-rx (make-regexp (regexp-quote version))))
	79	(match (regexp-exec version-rx uri)
	80	(#f
	81	uri)
	82	(_
	83	(let ((indices (fold-matches version-rx uri
	84	'((0))
	85	(lambda (m result)
	86	(match result
	87	(((start) rest ...)
	88	`((,(match:end m))
	89	(,start . ,(match:start m))
	90	,@rest)))))))
	91	(fold (lambda (index result)
	92	(match index
	93	((start)
	94	(cons (substring uri start)
	95	result))
	96	((start . end)
	97	(cons* (substring uri start end)
	98	'version
	99	result))))
	100	'()
	101	indices))))))
1ff2619b EB	102
	103	(define (hash-table->alist table)
	104	"Return an alist represenation of TABLE."
	105	(map (match-lambda
	106	((key . (lst ...))
	107	(cons key
	108	(map (lambda (x)
	109	(if (hash-table? x)
	110	(hash-table->alist x)
	111	x))
	112	lst)))
	113	((key . (? hash-table? table))
	114	(cons key (hash-table->alist table)))
	115	(pair pair))
	116	(hash-map->list cons table)))
	117
	118	(define (flatten lst)
	119	"Return a list that recursively concatenates all sub-lists of LST."
	120	(fold-right
	121	(match-lambda*
	122	(((sub-list ...) memo)
	123	(append (flatten sub-list) memo))
	124	((elem memo)
	125	(cons elem memo)))
	126	'() lst))
	127
	128	(define (assoc-ref* alist key . rest)
	129	"Return the value for KEY from ALIST. For each additional key specified,
	130	recursively apply the procedure to the sub-list."
	131	(if (null? rest)
	132	(assoc-ref alist key)
	133	(apply assoc-ref* (assoc-ref alist key) rest)))
	134
	135	(define (url-fetch url file-name)
	136	"Save the contents of URL to FILE-NAME. Return #f on failure."
	137	(parameterize ((current-output-port (current-error-port)))
	138	(build:url-fetch url file-name)))
140b3048 DT	139
	140	(define (guix-hash-url filename)
	141	"Return the hash of FILENAME in nix-base32 format."
	142	(bytevector->nix-base32-string (file-sha256 filename)))
	143
59b20347 DC	144	(define (spdx-string->license str)
	145	"Convert STR, a SPDX formatted license identifier, to a license object.
	146	Return #f if STR does not match any known identifiers."
	147	;; https://spdx.org/licenses/
	148	;; The psfl, gfl1.0, nmap, repoze
	149	;; licenses doesn't have SPDX identifiers
140b3048	150	(match str
59b20347 DC	151	("AGPL-1.0" 'license:agpl-1.0)
	152	("AGPL-3.0" 'license:agpl-3.0)
	153	("Apache-1.1" 'license:asl1.1)
	154	("Apache-2.0" 'license:asl2.0)
	155	("BSL-1.0" 'license:boost1.0)
	156	("BSD-2-Clause-FreeBSD" 'license:bsd-2)
	157	("BSD-3-Clause" 'license:bsd-3)
	158	("BSD-4-Clause" 'license:bsd-4)
	159	("CC0-1.0" 'license:cc0)
	160	("CC-BY-2.0" 'license:cc-by2.0)
	161	("CC-BY-3.0" 'license:cc-by3.0)
	162	("CC-BY-SA-2.0" 'license:cc-by-sa2.0)
	163	("CC-BY-SA-3.0" 'license:cc-by-sa3.0)
	164	("CC-BY-SA-4.0" 'license:cc-by-sa4.0)
	165	("CDDL-1.0" 'license:cddl1.0)
	166	("CECILL-C" 'license:cecill-c)
	167	("Artistic-2.0" 'license:artistic2.0)
	168	("ClArtistic" 'license:clarified-artistic)
	169	("CPL-1.0" 'license:cpl1.0)
	170	("EPL-1.0" 'license:epl1.0)
	171	("MIT" 'license:expat)
	172	("FTL" 'license:freetype)
	173	("GFDL-1.1" 'license:fdl1.1+)
	174	("GFDL-1.2" 'license:fdl1.2+)
	175	("GFDL-1.3" 'license:fdl1.3+)
	176	("Giftware" 'license:giftware)
	177	("GPL-1.0" 'license:gpl1)
	178	("GPL-1.0+" 'license:gpl1+)
	179	("GPL-2.0" 'license:gpl2)
	180	("GPL-2.0+" 'license:gpl2+)
	181	("GPL-3.0" 'license:gpl3)
	182	("GPL-3.0+" 'license:gpl3+)
	183	("ISC" 'license:isc)
	184	("IJG" 'license:ijg)
	185	("Imlib2" 'license:imlib2)
	186	("IPA" 'license:ipa)
	187	("IPL-1.0" 'license:ibmpl1.0)
	188	("LGPL-2.0" 'license:lgpl2.0)
	189	("LGPL-2.0+" 'license:lgpl2.0+)
	190	("LGPL-2.1" 'license:lgpl2.1)
	191	("LGPL-2.1+" 'license:lgpl2.1+)
	192	("LGPL-3.0" 'license:lgpl3.0)
	193	("LGPL-3.0+" 'license:lgpl3.0+)
	194	("MPL-1.0" 'license:mpl1.0)
	195	("MPL-1.1" 'license:mpl1.1)
	196	("MPL-2.0" 'license:mpl2.0)
	197	("MS-PL" 'license:ms-pl)
	198	("NCSA" 'license:ncsa)
	199	("OpenSSL" 'license:openssl)
	200	("OLDAP-2.8" 'license:openldap2.8)
	201	("CUA-OPL-1.0" 'license:opl1.0)
	202	("QPL-1.0" 'license:qpl)
	203	("Ruby" 'license:ruby)
	204	("SGI-B-2.0" 'license:sgifreeb2.0)
	205	("OFL-1.1" 'license:silofl1.1)
	206	("Sleepycat" 'license:sleepycat)
	207	("TCL" 'license:tcl/tk)
	208	("Unlicense" 'license:unlicense)
	209	("Vim" 'license:vim)
	210	("X11" 'license:x11)
	211	("ZPL-2.1" 'license:zpl2.1)
	212	("Zlib" 'license:zlib)
140b3048 DT	213	(_ #f)))
	214
	215	(define (license->symbol license)
	216	"Convert license to a symbol representing the variable the object is bound
	217	to in the (guix licenses) module, or #f if there is no such known license."
11e296ef DC	218	(define licenses
	219	(module-map (lambda (sym var) `(,(variable-ref var) . ,sym))
	220	(resolve-interface '(guix licenses) #:prefix 'license:)))
	221	(assoc-ref licenses license))
140b3048 DT	222
	223	(define (snake-case str)
	224	"Return a downcased version of the string STR where underscores are replaced
	225	with dashes."
	226	(string-join (string-split (string-downcase str) #\_) "-"))
2028a2c9 BW	227
	228	(define (beautify-description description)
	229	"Improve the package DESCRIPTION by turning a beginning sentence fragment
	230	into a proper sentence and by using two spaces between sentences."
	231	(let ((cleaned (if (string-prefix? "A " description)
	232	(string-append "This package provides a"
	233	(substring description 1))
	234	description)))
	235	;; Use double spacing between sentences
	236	(regexp-substitute/global #f "\\. \\b"
	237	cleaned 'pre ". " 'post)))
bb3f36ed	238
f1d13695	239	(define* (package-names->package-inputs names #:optional (output #f))
5a9ef8a9 IP	240	"Given a list of PACKAGE-NAMES, and an optional OUTPUT, tries to generate a
	241	quoted list of inputs, as suitable to use in an 'inputs' field of a package
	242	definition."
bb3f36ed	243	(map (lambda (input)
f1d13695 DC	244	(cons* input (list 'unquote (string->symbol input))
	245	(or (and output (list output))
	246	'())))
bb3f36ed DC	247	names))
bb3f36ed DC	248
f1d13695	249	(define* (maybe-inputs package-names #:optional (output #f))
bb3f36ed DC	250	"Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
bb3f36ed DC	251	package definition."
f1d13695	252	(match (package-names->package-inputs package-names output)
bb3f36ed DC	253	(()
	254	'())
	255	((package-inputs ...)
	256	`((inputs (,'quasiquote ,package-inputs))))))
	257
f1d13695	258	(define* (maybe-native-inputs package-names #:optional (output #f))
bb3f36ed DC	259	"Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
bb3f36ed DC	260	package definition."
f1d13695	261	(match (package-names->package-inputs package-names output)
bb3f36ed DC	262	(()
	263	'())
	264	((package-inputs ...)
	265	`((native-inputs (,'quasiquote ,package-inputs))))))
	266
	267	(define (package->definition guix-package)
	268	(match guix-package
	269	(('package ('name (? string? name)) _ ...)
	270	`(define-public ,(string->symbol name)
	271	,guix-package))))
5e892bc3 RW	272
	273	(define (build-system-modules)
	274	(all-modules (map (lambda (entry)
	275	`(,entry . "guix/build-system"))
	276	%load-path)))
	277
	278	(define (lookup-build-system-by-name name)
	279	"Return a <build-system> value for the symbol NAME, representing the name of
	280	the build system."
	281	(fold-module-public-variables (lambda (obj result)
	282	(if (and (build-system? obj)
	283	(eq? name (build-system-name obj)))
	284	obj result))
	285	#f
	286	(build-system-modules)))
	287
	288	(define (specs->package-lists specs)
	289	"Convert each string in the SPECS list to a list of a package label and a
	290	package value."
	291	(map (lambda (spec)
	292	(let-values (((pkg out) (specification->package+output spec)))
	293	(match out
f54cab27	294	("out" (list (package-name pkg) pkg))
5e892bc3 RW	295	(_ (list (package-name pkg) pkg out)))))
	296	specs))
	297
	298	(define (source-spec->object source)
	299	"Generate an <origin> object from a SOURCE specification. The SOURCE can
	300	either be a simple URL string, #F, or an alist containing entries for each of
	301	the expected fields of an <origin> object."
	302	(match source
	303	((? string? source-url)
	304	(let ((tarball (with-store store (download-to-store store source-url))))
	305	(origin
	306	(method url-fetch)
	307	(uri source-url)
	308	(sha256 (base32 (guix-hash-url tarball))))))
	309	(#f #f)
	310	(orig (let ((sha (match (assoc-ref orig "sha256")
	311	((("base32" . value))
	312	(base32 value))
	313	(_ #f))))
	314	(origin
	315	(method (match (assoc-ref orig "method")
	316	("url-fetch" (@ (guix download) url-fetch))
	317	("git-fetch" (@ (guix git-download) git-fetch))
	318	("svn-fetch" (@ (guix svn-download) svn-fetch))
	319	("hg-fetch" (@ (guix hg-download) hg-fetch))
	320	(_ #f)))
	321	(uri (assoc-ref orig "uri"))
	322	(sha256 sha))))))
	323
	324	(define (alist->package meta)
	325	(package
	326	(name (assoc-ref meta "name"))
	327	(version (assoc-ref meta "version"))
	328	(source (source-spec->object (assoc-ref meta "source")))
	329	(build-system
	330	(lookup-build-system-by-name
	331	(string->symbol (assoc-ref meta "build-system"))))
	332	(native-inputs
	333	(specs->package-lists (or (assoc-ref meta "native-inputs") '())))
	334	(inputs
	335	(specs->package-lists (or (assoc-ref meta "inputs") '())))
	336	(propagated-inputs
	337	(specs->package-lists (or (assoc-ref meta "propagated-inputs") '())))
	338	(home-page
	339	(assoc-ref meta "home-page"))
	340	(synopsis
	341	(assoc-ref meta "synopsis"))
	342	(description
	343	(assoc-ref meta "description"))
	344	(license
5e2495d0 LC	345	(match (assoc-ref meta "license")
	346	(#f #f)
	347	(l
	348	(or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:)
	349	(spdx-string->license l))
	350	(license:fsdg-compatible l)))))))
6b46b04f RW	351
	352	(define* (read-lines #:optional (port (current-input-port)))
	353	"Read lines from PORT and return them as a list."
	354	(let loop ((line (read-line port))
	355	(lines '()))
	356	(if (eof-object? line)
	357	(reverse lines)
	358	(loop (read-line port)
	359	(cons line lines)))))
	360
	361	(define* (chunk-lines lines #:optional (pred string-null?))
	362	"Return a list of chunks, each of which is a list of lines. The chunks are
	363	separated by PRED."
	364	(let loop ((rest lines)
	365	(parts '()))
	366	(receive (before after)
	367	(break pred rest)
	368	(let ((res (cons before parts)))
	369	(if (null? after)
	370	(reverse res)
	371	(loop (cdr after) res))))))
ae9e5d66 OP	372
	373	(define (guix-name prefix name)
	374	"Return a Guix package name for a given package name."
	375	(string-append prefix (string-map (match-lambda
	376	(#\_ #\-)
	377	(#\. #\-)
	378	(chr (char-downcase chr)))
	379	name)))
	380
	381	(define* (recursive-import package-name repo
	382	#:key repo->guix-package guix-name
	383	#:allow-other-keys)
	384	"Generate a stream of package expressions for PACKAGE-NAME and all its
	385	dependencies."
5b315f3e RV	386	(define (exists? dependency)
	387	(not (null? (find-packages-by-name (guix-name dependency)))))
	388	(define initial-state (list #f (list package-name) (list)))
	389	(define (step state)
	390	(match state
	391	((prev (next . rest) done)
	392	(define (handle? dep)
	393	(and
	394	(not (equal? dep next))
	395	(not (member dep done))
	396	(not (exists? dep))))
	397	(receive (package . dependencies) (repo->guix-package next repo)
	398	(list
	399	(if package package '()) ;; default #f on failure would interrupt
	400	(if package
	401	(lset-union equal? rest (filter handle? (car dependencies)))
	402	rest)
	403	(cons next done))))
	404	((prev '() done)
	405	(list #f '() done))))
	406
	407	;; Generate a lazy stream of package expressions for all unknown
	408	;; dependencies in the graph.
	409	(stream-unfold
	410	;; map: produce a stream element
	411	(match-lambda ((latest queue done) latest))
	412	;; predicate
	413	(match-lambda ((latest queue done) latest))
	414	;; generator: update the queue
	415	step
	416	;; initial state
	417	(step initial-state)))