guix/import/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix import utils)
  20   #:use-module (ice-9 match)
  21   #:use-module (ice-9 regex)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (guix hash)
  24   #:use-module (guix base32)
  25   #:use-module (guix licenses)
  26   #:use-module (guix utils)
  27   #:use-module ((guix build download) #:prefix build:)
  28   #:export (factorize-uri
  29
  30             hash-table->alist
  31             flatten
  32             assoc-ref*
  33
  34             url-fetch
  35             guix-hash-url
  36
  37             string->license
  38             license->symbol
  39
  40             snake-case
  41             beautify-description))
  42
  43 (define (factorize-uri uri version)
  44   "Factorize URI, a package tarball URI as a string, such that any occurrences
  45 of the string VERSION is replaced by the symbol 'version."
  46   (let ((version-rx (make-regexp (regexp-quote version))))
  47     (match (regexp-exec version-rx uri)
  48       (#f
  49        uri)
  50       (_
  51        (let ((indices (fold-matches version-rx uri
  52                                     '((0))
  53                                     (lambda (m result)
  54                                       (match result
  55                                         (((start) rest ...)
  56                                          `((,(match:end m))
  57                                            (,start . ,(match:start m))
  58                                            ,@rest)))))))
  59          (fold (lambda (index result)
  60                  (match index
  61                    ((start)
  62                     (cons (substring uri start)
  63                           result))
  64                    ((start . end)
  65                     (cons* (substring uri start end)
  66                            'version
  67                            result))))
  68                '()
  69                indices))))))
  70
  71 (define (hash-table->alist table)
  72   "Return an alist represenation of TABLE."
  73   (map (match-lambda
  74         ((key . (lst ...))
  75          (cons key
  76                (map (lambda (x)
  77                       (if (hash-table? x)
  78                           (hash-table->alist x)
  79                           x))
  80                     lst)))
  81         ((key . (? hash-table? table))
  82          (cons key (hash-table->alist table)))
  83         (pair pair))
  84        (hash-map->list cons table)))
  85
  86 (define (flatten lst)
  87   "Return a list that recursively concatenates all sub-lists of LST."
  88   (fold-right
  89    (match-lambda*
  90     (((sub-list ...) memo)
  91      (append (flatten sub-list) memo))
  92     ((elem memo)
  93      (cons elem memo)))
  94    '() lst))
  95
  96 (define (assoc-ref* alist key . rest)
  97   "Return the value for KEY from ALIST.  For each additional key specified,
  98 recursively apply the procedure to the sub-list."
  99   (if (null? rest)
 100       (assoc-ref alist key)
 101       (apply assoc-ref* (assoc-ref alist key) rest)))
 102
 103 (define (url-fetch url file-name)
 104   "Save the contents of URL to FILE-NAME.  Return #f on failure."
 105   (parameterize ((current-output-port (current-error-port)))
 106     (build:url-fetch url file-name)))
 107
 108 (define (guix-hash-url filename)
 109   "Return the hash of FILENAME in nix-base32 format."
 110   (bytevector->nix-base32-string (file-sha256 filename)))
 111
 112 (define (string->license str)
 113   "Convert the string STR into a license object."
 114   (match str
 115     ("GNU LGPL" lgpl2.0)
 116     ("GPL" gpl3)
 117     ((or "BSD" "BSD License") bsd-3)
 118     ((or "MIT" "MIT license" "Expat license") expat)
 119     ("Public domain" public-domain)
 120     ((or "Apache License, Version 2.0" "Apache 2.0") asl2.0)
 121     (_ #f)))
 122
 123 (define (license->symbol license)
 124   "Convert license to a symbol representing the variable the object is bound
 125 to in the (guix licenses) module, or #f if there is no such known license."
 126   ;; TODO: Traverse list public variables in (guix licenses) instead so we
 127   ;; don't have to maintain a list manualy.
 128   (assoc-ref `((,lgpl2.0 . lgpl2.0)
 129                (,gpl3 . gpl3)
 130                (,bsd-3 . bsd-3)
 131                (,expat . expat)
 132                (,public-domain . public-domain)
 133                (,asl2.0 . asl2.0))
 134              license))
 135
 136 (define (snake-case str)
 137   "Return a downcased version of the string STR where underscores are replaced
 138 with dashes."
 139   (string-join (string-split (string-downcase str) #\_) "-"))
 140
 141 (define (beautify-description description)
 142   "Improve the package DESCRIPTION by turning a beginning sentence fragment
 143 into a proper sentence and by using two spaces between sentences."
 144   (let ((cleaned (if (string-prefix? "A " description)
 145                      (string-append "This package provides a"
 146                                     (substring description 1))
 147                      description)))
 148     ;; Use double spacing between sentences
 149     (regexp-substitute/global #f "\\. \\b"
 150                               cleaned 'pre ".  " 'post)))