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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017, 2019, 2020 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) #:hide (sha256))
  #: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 (guix sets)
  #: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-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (factorize-uri

            flatten

            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 (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 (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 (cond
                  ((string-prefix? "A " description)
                   (string-append "This package provides a"
                                  (substring description 1)))
                  ((string-prefix? "Provides " description)
                   (string-append "This package provides"
                                  (substring description
                                             (string-length "Provides"))))
                  ((string-prefix? "Functions " description)
                   (string-append "This package provides functions"
                                  (substring description
                                             (string-length "Functions"))))
                  (else 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))
    (('let anything ('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 #:optional (known-inputs '()))
  "Return a package value generated from the alist META.  If the list of
strings KNOWN-INPUTS is provided, do not treat the mentioned inputs as
specifications to look up and replace them with plain symbols instead."
  (define (process-inputs which)
    (let-values (((regular known)
                  (lset-diff+intersection
                   string=?
                   (vector->list (or (assoc-ref meta which) #()))
                   known-inputs)))
      (append (specs->package-lists regular)
              (map string->symbol known))))
  (define (process-arguments arguments)
    (append-map (match-lambda
                  ((key . value)
                   (list (symbol->keyword (string->symbol key)) value)))
                arguments))
  (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"))))
    (arguments
     (or (and=> (assoc-ref meta "arguments")
                process-arguments)
         '()))
    (native-inputs (process-inputs "native-inputs"))
    (inputs (process-inputs "inputs"))
    (propagated-inputs (process-inputs "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 (topological-sort nodes
                          node-dependencies
                          node-name)
  "Perform a breadth-first traversal of the graph rooted at NODES, a list of
nodes, and return the list of nodes sorted in topological order.  Call
NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
obtain a node's uniquely identifying \"key\"."
  (let loop ((nodes nodes)
             (result '())
             (visited (set)))
    (match nodes
      (()
       result)
      ((head . tail)
       (if (set-contains? visited (node-name head))
           (loop tail result visited)
           (let ((dependencies (node-dependencies head)))
             (loop (append dependencies tail)
                   (cons head result)
                   (set-insert (node-name head) visited))))))))

(define* (recursive-import package-name repo
                           #:key repo->guix-package guix-name
                           #:allow-other-keys)
  "Return a list of package expressions for PACKAGE-NAME and all its
dependencies, sorted in topological order.  For each package,
call (REPO->GUIX-PACKAGE NAME REPO), which should return a package expression
and a list of dependencies; call (GUIX-NAME NAME) to obtain the Guix package
name corresponding to the upstream name."
  (define-record-type <node>
    (make-node name package dependencies)
    node?
    (name         node-name)
    (package      node-package)
    (dependencies node-dependencies))

  (define (exists? name)
    (not (null? (find-packages-by-name (guix-name name)))))

  (define (lookup-node name)
    (receive (package dependencies) (repo->guix-package name repo)
      (make-node name package dependencies)))

  (map node-package
       (topological-sort (list (lookup-node package-name))
                         (lambda (node)
                           (map lookup-node
                                (remove exists?
                                        (node-dependencies node))))
                         node-name)))
Commit	Line	Data
1b3e9685	1	;;; GNU Guix --- Functional package management for GNU
2d0409a4	2	;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
59b20347	3	;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
11e296ef	4	;;; Copyright © 2016 David Craven <david@craven.ch>
3532fc39	5	;;; Copyright © 2017, 2019, 2020 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:)
ce0be567	27	#:use-module ((gcrypt hash) #:hide (sha256))
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)
ddd59159	37	#:use-module (guix sets)
5e892bc3	38	#:use-module (gnu packages)
fbe9c101	39	#:use-module (ice-9 match)
6b46b04f RW	40	#:use-module (ice-9 rdelim)
6b46b04f RW	41	#:use-module (ice-9 receive)
fbe9c101	42	#:use-module (ice-9 regex)
fbe9c101	43	#:use-module (srfi srfi-1)
ddd59159	44	#:use-module (srfi srfi-9)
5e892bc3	45	#:use-module (srfi srfi-11)
ae9e5d66	46	#:use-module (srfi srfi-26)
1ff2619b EB	47	#:export (factorize-uri
1ff2619b EB	48
1ff2619b	49	flatten
1ff2619b	50
140b3048 DT	51	url-fetch
	52	guix-hash-url
	53
5a9ef8a9	54	package-names->package-inputs
bb3f36ed DC	55	maybe-inputs
	56	maybe-native-inputs
	57	package->definition
	58
59b20347	59	spdx-string->license
140b3048 DT	60	license->symbol
140b3048 DT	61
2028a2c9	62	snake-case
5e892bc3 RW	63	beautify-description
5e892bc3 RW	64
6b46b04f RW	65	alist->package
	66
	67	read-lines
ae9e5d66 OP	68	chunk-lines
	69
	70	guix-name
	71
	72	recursive-import))
1b3e9685 DT	73
	74	(define (factorize-uri uri version)
	75	"Factorize URI, a package tarball URI as a string, such that any occurrences
	76	of the string VERSION is replaced by the symbol 'version."
	77	(let ((version-rx (make-regexp (regexp-quote version))))
	78	(match (regexp-exec version-rx uri)
	79	(#f
	80	uri)
	81	(_
	82	(let ((indices (fold-matches version-rx uri
	83	'((0))
	84	(lambda (m result)
	85	(match result
	86	(((start) rest ...)
	87	`((,(match:end m))
	88	(,start . ,(match:start m))
	89	,@rest)))))))
	90	(fold (lambda (index result)
	91	(match index
	92	((start)
	93	(cons (substring uri start)
	94	result))
	95	((start . end)
	96	(cons* (substring uri start end)
	97	'version
	98	result))))
	99	'()
	100	indices))))))
1ff2619b	101
1ff2619b EB	102	(define (flatten lst)
	103	"Return a list that recursively concatenates all sub-lists of LST."
	104	(fold-right
	105	(match-lambda*
	106	(((sub-list ...) memo)
	107	(append (flatten sub-list) memo))
	108	((elem memo)
	109	(cons elem memo)))
	110	'() lst))
	111
1ff2619b EB	112	(define (url-fetch url file-name)
	113	"Save the contents of URL to FILE-NAME. Return #f on failure."
	114	(parameterize ((current-output-port (current-error-port)))
	115	(build:url-fetch url file-name)))
140b3048 DT	116
	117	(define (guix-hash-url filename)
	118	"Return the hash of FILENAME in nix-base32 format."
	119	(bytevector->nix-base32-string (file-sha256 filename)))
	120
59b20347 DC	121	(define (spdx-string->license str)
	122	"Convert STR, a SPDX formatted license identifier, to a license object.
	123	Return #f if STR does not match any known identifiers."
	124	;; https://spdx.org/licenses/
	125	;; The psfl, gfl1.0, nmap, repoze
	126	;; licenses doesn't have SPDX identifiers
140b3048	127	(match str
59b20347 DC	128	("AGPL-1.0" 'license:agpl-1.0)
	129	("AGPL-3.0" 'license:agpl-3.0)
	130	("Apache-1.1" 'license:asl1.1)
	131	("Apache-2.0" 'license:asl2.0)
	132	("BSL-1.0" 'license:boost1.0)
	133	("BSD-2-Clause-FreeBSD" 'license:bsd-2)
	134	("BSD-3-Clause" 'license:bsd-3)
	135	("BSD-4-Clause" 'license:bsd-4)
	136	("CC0-1.0" 'license:cc0)
	137	("CC-BY-2.0" 'license:cc-by2.0)
	138	("CC-BY-3.0" 'license:cc-by3.0)
	139	("CC-BY-SA-2.0" 'license:cc-by-sa2.0)
	140	("CC-BY-SA-3.0" 'license:cc-by-sa3.0)
	141	("CC-BY-SA-4.0" 'license:cc-by-sa4.0)
	142	("CDDL-1.0" 'license:cddl1.0)
	143	("CECILL-C" 'license:cecill-c)
	144	("Artistic-2.0" 'license:artistic2.0)
	145	("ClArtistic" 'license:clarified-artistic)
	146	("CPL-1.0" 'license:cpl1.0)
	147	("EPL-1.0" 'license:epl1.0)
	148	("MIT" 'license:expat)
	149	("FTL" 'license:freetype)
	150	("GFDL-1.1" 'license:fdl1.1+)
	151	("GFDL-1.2" 'license:fdl1.2+)
	152	("GFDL-1.3" 'license:fdl1.3+)
	153	("Giftware" 'license:giftware)
	154	("GPL-1.0" 'license:gpl1)
	155	("GPL-1.0+" 'license:gpl1+)
	156	("GPL-2.0" 'license:gpl2)
	157	("GPL-2.0+" 'license:gpl2+)
	158	("GPL-3.0" 'license:gpl3)
	159	("GPL-3.0+" 'license:gpl3+)
	160	("ISC" 'license:isc)
	161	("IJG" 'license:ijg)
	162	("Imlib2" 'license:imlib2)
	163	("IPA" 'license:ipa)
	164	("IPL-1.0" 'license:ibmpl1.0)
	165	("LGPL-2.0" 'license:lgpl2.0)
	166	("LGPL-2.0+" 'license:lgpl2.0+)
	167	("LGPL-2.1" 'license:lgpl2.1)
	168	("LGPL-2.1+" 'license:lgpl2.1+)
	169	("LGPL-3.0" 'license:lgpl3.0)
	170	("LGPL-3.0+" 'license:lgpl3.0+)
	171	("MPL-1.0" 'license:mpl1.0)
	172	("MPL-1.1" 'license:mpl1.1)
	173	("MPL-2.0" 'license:mpl2.0)
	174	("MS-PL" 'license:ms-pl)
	175	("NCSA" 'license:ncsa)
	176	("OpenSSL" 'license:openssl)
	177	("OLDAP-2.8" 'license:openldap2.8)
	178	("CUA-OPL-1.0" 'license:opl1.0)
	179	("QPL-1.0" 'license:qpl)
	180	("Ruby" 'license:ruby)
	181	("SGI-B-2.0" 'license:sgifreeb2.0)
	182	("OFL-1.1" 'license:silofl1.1)
	183	("Sleepycat" 'license:sleepycat)
	184	("TCL" 'license:tcl/tk)
	185	("Unlicense" 'license:unlicense)
	186	("Vim" 'license:vim)
	187	("X11" 'license:x11)
	188	("ZPL-2.1" 'license:zpl2.1)
	189	("Zlib" 'license:zlib)
140b3048 DT	190	(_ #f)))
	191
	192	(define (license->symbol license)
	193	"Convert license to a symbol representing the variable the object is bound
	194	to in the (guix licenses) module, or #f if there is no such known license."
11e296ef DC	195	(define licenses
	196	(module-map (lambda (sym var) `(,(variable-ref var) . ,sym))
	197	(resolve-interface '(guix licenses) #:prefix 'license:)))
	198	(assoc-ref licenses license))
140b3048 DT	199
	200	(define (snake-case str)
	201	"Return a downcased version of the string STR where underscores are replaced
	202	with dashes."
	203	(string-join (string-split (string-downcase str) #\_) "-"))
2028a2c9 BW	204
	205	(define (beautify-description description)
	206	"Improve the package DESCRIPTION by turning a beginning sentence fragment
	207	into a proper sentence and by using two spaces between sentences."
6e377b88 RW	208	(let ((cleaned (cond
	209	((string-prefix? "A " description)
	210	(string-append "This package provides a"
	211	(substring description 1)))
	212	((string-prefix? "Provides " description)
	213	(string-append "This package provides"
	214	(substring description
	215	(string-length "Provides"))))
	216	((string-prefix? "Functions " description)
	217	(string-append "This package provides functions"
	218	(substring description
	219	(string-length "Functions"))))
	220	(else description))))
2028a2c9 BW	221	;; Use double spacing between sentences
	222	(regexp-substitute/global #f "\\. \\b"
	223	cleaned 'pre ". " 'post)))
bb3f36ed	224
f1d13695	225	(define* (package-names->package-inputs names #:optional (output #f))
5a9ef8a9 IP	226	"Given a list of PACKAGE-NAMES, and an optional OUTPUT, tries to generate a
	227	quoted list of inputs, as suitable to use in an 'inputs' field of a package
	228	definition."
bb3f36ed	229	(map (lambda (input)
f1d13695 DC	230	(cons* input (list 'unquote (string->symbol input))
	231	(or (and output (list output))
	232	'())))
bb3f36ed DC	233	names))
bb3f36ed DC	234
f1d13695	235	(define* (maybe-inputs package-names #:optional (output #f))
bb3f36ed DC	236	"Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
bb3f36ed DC	237	package definition."
f1d13695	238	(match (package-names->package-inputs package-names output)
bb3f36ed DC	239	(()
	240	'())
	241	((package-inputs ...)
	242	`((inputs (,'quasiquote ,package-inputs))))))
	243
f1d13695	244	(define* (maybe-native-inputs package-names #:optional (output #f))
bb3f36ed DC	245	"Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
bb3f36ed DC	246	package definition."
f1d13695	247	(match (package-names->package-inputs package-names output)
bb3f36ed DC	248	(()
	249	'())
	250	((package-inputs ...)
	251	`((native-inputs (,'quasiquote ,package-inputs))))))
	252
	253	(define (package->definition guix-package)
	254	(match guix-package
	255	(('package ('name (? string? name)) _ ...)
ad553ec4 RW	256	`(define-public ,(string->symbol name)
	257	,guix-package))
	258	(('let anything ('package ('name (? string? name)) _ ...))
bb3f36ed DC	259	`(define-public ,(string->symbol name)
bb3f36ed DC	260	,guix-package))))
5e892bc3 RW	261
	262	(define (build-system-modules)
	263	(all-modules (map (lambda (entry)
	264	`(,entry . "guix/build-system"))
	265	%load-path)))
	266
	267	(define (lookup-build-system-by-name name)
	268	"Return a <build-system> value for the symbol NAME, representing the name of
	269	the build system."
	270	(fold-module-public-variables (lambda (obj result)
	271	(if (and (build-system? obj)
	272	(eq? name (build-system-name obj)))
	273	obj result))
	274	#f
	275	(build-system-modules)))
	276
	277	(define (specs->package-lists specs)
	278	"Convert each string in the SPECS list to a list of a package label and a
	279	package value."
	280	(map (lambda (spec)
	281	(let-values (((pkg out) (specification->package+output spec)))
	282	(match out
f54cab27	283	("out" (list (package-name pkg) pkg))
5e892bc3 RW	284	(_ (list (package-name pkg) pkg out)))))
	285	specs))
	286
	287	(define (source-spec->object source)
	288	"Generate an <origin> object from a SOURCE specification. The SOURCE can
	289	either be a simple URL string, #F, or an alist containing entries for each of
	290	the expected fields of an <origin> object."
	291	(match source
	292	((? string? source-url)
	293	(let ((tarball (with-store store (download-to-store store source-url))))
	294	(origin
	295	(method url-fetch)
	296	(uri source-url)
	297	(sha256 (base32 (guix-hash-url tarball))))))
	298	(#f #f)
	299	(orig (let ((sha (match (assoc-ref orig "sha256")
	300	((("base32" . value))
	301	(base32 value))
	302	(_ #f))))
	303	(origin
	304	(method (match (assoc-ref orig "method")
	305	("url-fetch" (@ (guix download) url-fetch))
	306	("git-fetch" (@ (guix git-download) git-fetch))
	307	("svn-fetch" (@ (guix svn-download) svn-fetch))
	308	("hg-fetch" (@ (guix hg-download) hg-fetch))
	309	(_ #f)))
	310	(uri (assoc-ref orig "uri"))
	311	(sha256 sha))))))
	312
3532fc39 RW	313	(define* (alist->package meta #:optional (known-inputs '()))
	314	"Return a package value generated from the alist META. If the list of
	315	strings KNOWN-INPUTS is provided, do not treat the mentioned inputs as
	316	specifications to look up and replace them with plain symbols instead."
	317	(define (process-inputs which)
	318	(let-values (((regular known)
	319	(lset-diff+intersection
	320	string=?
	321	(vector->list (or (assoc-ref meta which) #()))
	322	known-inputs)))
	323	(append (specs->package-lists regular)
	324	(map string->symbol known))))
3fd4c4c8 RW	325	(define (process-arguments arguments)
	326	(append-map (match-lambda
	327	((key . value)
	328	(list (symbol->keyword (string->symbol key)) value)))
	329	arguments))
5e892bc3 RW	330	(package
	331	(name (assoc-ref meta "name"))
	332	(version (assoc-ref meta "version"))
	333	(source (source-spec->object (assoc-ref meta "source")))
	334	(build-system
	335	(lookup-build-system-by-name
	336	(string->symbol (assoc-ref meta "build-system"))))
3fd4c4c8 RW	337	(arguments
	338	(or (and=> (assoc-ref meta "arguments")
	339	process-arguments)
	340	'()))
3532fc39 RW	341	(native-inputs (process-inputs "native-inputs"))
	342	(inputs (process-inputs "inputs"))
	343	(propagated-inputs (process-inputs "propagated-inputs"))
5e892bc3 RW	344	(home-page
	345	(assoc-ref meta "home-page"))
	346	(synopsis
	347	(assoc-ref meta "synopsis"))
	348	(description
	349	(assoc-ref meta "description"))
	350	(license
5e2495d0 LC	351	(match (assoc-ref meta "license")
	352	(#f #f)
	353	(l
	354	(or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:)
	355	(spdx-string->license l))
	356	(license:fsdg-compatible l)))))))
6b46b04f RW	357
	358	(define* (read-lines #:optional (port (current-input-port)))
	359	"Read lines from PORT and return them as a list."
	360	(let loop ((line (read-line port))
	361	(lines '()))
	362	(if (eof-object? line)
	363	(reverse lines)
	364	(loop (read-line port)
	365	(cons line lines)))))
	366
	367	(define* (chunk-lines lines #:optional (pred string-null?))
	368	"Return a list of chunks, each of which is a list of lines. The chunks are
	369	separated by PRED."
	370	(let loop ((rest lines)
	371	(parts '()))
	372	(receive (before after)
	373	(break pred rest)
	374	(let ((res (cons before parts)))
	375	(if (null? after)
	376	(reverse res)
	377	(loop (cdr after) res))))))
ae9e5d66 OP	378
	379	(define (guix-name prefix name)
	380	"Return a Guix package name for a given package name."
	381	(string-append prefix (string-map (match-lambda
	382	(#\_ #\-)
	383	(#\. #\-)
	384	(chr (char-downcase chr)))
	385	name)))
	386
ddd59159 LC	387	(define (topological-sort nodes
	388	node-dependencies
	389	node-name)
	390	"Perform a breadth-first traversal of the graph rooted at NODES, a list of
	391	nodes, and return the list of nodes sorted in topological order. Call
	392	NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
	393	obtain a node's uniquely identifying \"key\"."
	394	(let loop ((nodes nodes)
	395	(result '())
	396	(visited (set)))
	397	(match nodes
	398	(()
	399	result)
	400	((head . tail)
	401	(if (set-contains? visited (node-name head))
	402	(loop tail result visited)
	403	(let ((dependencies (node-dependencies head)))
	404	(loop (append dependencies tail)
	405	(cons head result)
	406	(set-insert (node-name head) visited))))))))
	407
ae9e5d66 OP	408	(define* (recursive-import package-name repo
	409	#:key repo->guix-package guix-name
	410	#:allow-other-keys)
6212146f	411	"Return a list of package expressions for PACKAGE-NAME and all its
ddd59159 LC	412	dependencies, sorted in topological order. For each package,
	413	call (REPO->GUIX-PACKAGE NAME REPO), which should return a package expression
	414	and a list of dependencies; call (GUIX-NAME NAME) to obtain the Guix package
	415	name corresponding to the upstream name."
	416	(define-record-type <node>
	417	(make-node name package dependencies)
	418	node?
	419	(name node-name)
	420	(package node-package)
	421	(dependencies node-dependencies))
	422
	423	(define (exists? name)
	424	(not (null? (find-packages-by-name (guix-name name)))))
	425
	426	(define (lookup-node name)
	427	(receive (package dependencies) (repo->guix-package name repo)
	428	(make-node name package dependencies)))
	429
70a8e132 LC	430	(map node-package
	431	(topological-sort (list (lookup-node package-name))
	432	(lambda (node)
	433	(map lookup-node
	434	(remove exists?
	435	(node-dependencies node))))
	436	node-name)))