From 7f74a931ddccdb3b42558f8f8ee29b309d9231b9 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Tue, 16 Jun 2015 10:50:06 +0200 Subject: import: Add 'elpa' importer. * guix/import/elpa.scm: New file. * guix/scripts/import.scm: Add "elpa" to 'importers'. * guix/scripts/import/elpa.scm: New file. * Makefile.am (MODULES): Add 'guix/import/elpa.scm' and 'guix/scripts/import/elpa.scm'. (SCM_TESTS): Add 'tests/elpa.scm'. * doc/guix.texi (Invoking guix import): Document it. * tests/elpa.scm: New file. * po/guix/POTFILES.in: Add 'guix/scripts/import/elpa.scm'. --- guix/import/elpa.scm | 230 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 230 insertions(+) create mode 100644 guix/import/elpa.scm (limited to 'guix/import') diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm new file mode 100644 index 0000000000..3b3dc1f91a --- /dev/null +++ b/guix/import/elpa.scm @@ -0,0 +1,230 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa +;;; +;;; 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 . + +(define-module (guix import elpa) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module ((guix download) #:select (download-to-store)) + #:use-module (guix import utils) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (guix hash) + #:use-module (guix base32) + #:use-module ((guix utils) #:select (call-with-temporary-output-file + memoize)) + #:export (elpa->guix-package)) + +(define (elpa-dependencies->names deps) + "Convert DEPS, a list of symbol/version pairs à la ELPA, to a list of +package names as strings" + (match deps + (((names _ ...) ...) + (map symbol->string names)))) + +(define emacs-standard-library? + (let ((libs '("emacs" "cl-lib"))) + (lambda (lib) + "Return true if LIB is part of Emacs itself. The check is not +exhaustive and only attempts to recognize a subset of packages which in the +past were distributed separately from Emacs." + (member lib libs)))) + +(define (filter-dependencies names) + "Remove the package names included with Emacs from the list of +NAMES (strings)." + (filter emacs-standard-library? names)) + +(define (elpa-name->package-name name) + "Given the NAME of an Emacs package, return the corresponding Guix name." + (let ((package-name-prefix "emacs-")) + (if (string-prefix? package-name-prefix name) + (string-downcase name) + (string-append package-name-prefix (string-downcase name))))) + +(define* (elpa-url #:optional (repo 'gnu)) + "Retrun the URL of REPO." + (let ((elpa-archives + '((gnu . "http://elpa.gnu.org/packages") + (melpa-stable . "http://stable.melpa.org/packages") + (melpa . "http://melpa.org/packages")))) + (assq-ref elpa-archives repo))) + +(define* (elpa-fetch-archive #:optional (repo 'gnu)) + "Retrive the archive with the list of packages available from REPO." + (let ((url (and=> (elpa-url repo) + (cut string-append <> "/archive-contents")))) + (if url + (call-with-downloaded-file url read) + (leave (_ "~A: currently not supported~%") repo)))) + +(define (call-with-downloaded-file url proc) + "Fetch URL, store the content in a temporary file and call PROC with that +file. Returns the value returned by PROC." + (call-with-temporary-output-file + (lambda (temp port) + (or (and (url-fetch url temp) + (call-with-input-file temp proc)) + (error "download failed" url))))) + +(define (is-elpa-package? name elpa-pkg-spec) + "Return true if the string NAME corresponds to the name of the package +defined by ELPA-PKG-SPEC, a package specification as in an archive +'archive-contents' file." + (eq? (first elpa-pkg-spec) (string->symbol name))) + +(define* (elpa-package-info name #:optional (repo 'gnu)) + "Extract the information about the package NAME from the package archieve of +REPO." + (let* ((archive (elpa-fetch-archive repo)) + (pkgs (match archive ((version pkg-spec ...) pkg-spec))) + (info (filter (cut is-elpa-package? name <>) pkgs))) + (if (pair? info) (first info) #f))) + +;; Object to store information about an ELPA package. +(define-record-type + (make-elpa-package name version inputs synopsis kind home-page description + source-url) + elpa-package? + (name elpa-package-name) + (version elpa-package-version) + (inputs elpa-package-inputs) + (synopsis elpa-package-synopsis) + (kind elpa-package-kind) + (home-page elpa-package-home-page) + (description elpa-package-description) + (source-url elpa-package-source-url)) + +(set-record-type-printer! + (lambda (package port) + (format port "#" + (elpa-package-name package) + (elpa-package-version package)))) + +(define (elpa-version->string elpa-version) + "Convert the package version as used in Emacs package files into a string." + (if (pair? elpa-version) + (let-values (((ms rest) (match elpa-version + ((ms . rest) + (values ms rest))))) + (fold (lambda (n s) (string-append s "." (number->string n))) + (number->string ms) rest)) + #f)) + +(define (package-home-page alist) + "Extract the package home-page from ALIST." + (or (assq-ref alist ':url) "unspecified")) + +(define (ensure-list alist) + "If ALIST is the symbol 'nil return the empty list. Otherwise, return ALIST." + (if (eq? alist 'nil) + '() + alist)) + +(define (package-source-url kind name version repo) + "Return the source URL of the package described the the strings NAME and +VERSION at REPO. KIND is either the symbol 'single or 'tar." + (case kind + ((single) (full-url repo name ".el" version)) + ((tar) (full-url repo name ".tar" version)) + (else + #f))) + +(define* (full-url repo name suffix #:optional (version #f)) + "Return the full URL of the package NAME at REPO and the SUFFIX. Maybe +include VERSION." + (if version + (string-append (elpa-url repo) "/" name "-" version suffix) + (string-append (elpa-url repo) "/" name suffix))) + +(define (fetch-package-description kind name repo) + "Fetch the description of package NAME of type KIND from REPO." + (let ((url (full-url repo name "-readme.txt"))) + (call-with-downloaded-file url read-string))) + +(define* (fetch-elpa-package name #:optional (repo 'gnu)) + "Fetch package NAME from REPO." + (let ((pkg (elpa-package-info name repo))) + (match pkg + ((name version reqs synopsis kind . rest) + (let* ((name (symbol->string name)) + (ver (elpa-version->string version)) + (url (package-source-url kind name ver repo))) + (make-elpa-package name ver + (ensure-list reqs) synopsis kind + (package-home-page (first rest)) + (fetch-package-description kind name repo) + url))) + (_ #f)))) + +(define* (elpa-package->sexp pkg) + "Return the `package' S-expression for the Emacs package PKG, a record of +type ''." + + (define name (elpa-package-name pkg)) + + (define version (elpa-package-version pkg)) + + (define source-url (elpa-package-source-url pkg)) + + (define dependencies + (let* ((deps (elpa-package-inputs pkg)) + (names (filter-dependencies (elpa-dependencies->names deps)))) + (map (lambda (n) + (let ((new-n (elpa-name->package-name n))) + (list new-n (list 'unquote (string->symbol new-n))))) + names))) + + (define (maybe-inputs input-type inputs) + (match inputs + (() + '()) + ((inputs ...) + (list (list input-type + (list 'quasiquote inputs)))))) + + (let ((tarball (with-store store + (download-to-store store source-url)))) + `(package + (name ,(elpa-name->package-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(if tarball + (bytevector->nix-base32-string (file-sha256 tarball)) + "failed to download package"))))) + (build-system emacs-build-system) + ,@(maybe-inputs 'inputs dependencies) + (home-page ,(elpa-package-home-page pkg)) + (synopsis ,(elpa-package-synopsis pkg)) + (description ,(elpa-package-description pkg)) + (license license:gpl3+)))) + +(define* (elpa->guix-package name #:optional (repo 'gnu)) + "Fetch the package NAME from REPO and produce a Guix package S-expression." + (let ((pkg (fetch-elpa-package name repo))) + (and=> pkg elpa-package->sexp))) + +;;; elpa.scm ends here -- cgit v1.2.3