;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <address@hidden>
;;;
;;; 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 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 ((guix download) #:select (download-to-store))
  #:use-module (guix import utils)
  #:use-module (guix store)
  #: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 the list of dependencies from the ELPA format, to a list of string
names."
  (map (lambda (d) (symbol->string (first d))) deps))

(define (filter-dependencies names)
  "Remove the package names included with Emacs from the list of
NAMES (strings)."
  (let ((emacs-standard-libraries
         '("emacs" "cl-lib")))
    (filter (lambda (d) (not (member d emacs-standard-libraries)))
            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"))))
    (assoc-ref elpa-archives repo)))

(define* (elpa-fetch-archive #:optional (repo "gnu"))
  "Retrive the archive with the list of packages available from REPO."
  (let ((url (string-append (elpa-url repo) "/archive-contents")))
    (fetch-and-call-with-input-file url read)))

;; Fetch URL, store the content in a temporary file and call PROC with that
;; file.
(define fetch-and-call-with-input-file
  (memoize
   (lambda* (url proc #:optional (err-msg "unavailable"))
     (call-with-temporary-output-file
      (lambda (temp port)
        (or (and (url-fetch url temp)
                 (call-with-input-file temp proc))
            err-msg))))))

(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))
         (info (filter (lambda (p) (eq? (first p) (string->symbol name)))
                       (cdr archive))))
    (if (pair? info) (first info) #f)))

;; Object to store information about an ELPA package.
(define-record-type <elpa-package>
  (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! <elpa-package>
                          (lambda (package port)
                            (format port "#<elpa-package ~a-~a>"
                                      (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 (lookup-extra alist key)
  "Lookup KEY from the ALIST extra package information."
  (assq-ref alist key))

(define (package-home-page alist)
  "Extract the package home-page from ALIST."
  (or (lookup-extra alist ':url) "unspecified"))

(define (nil->empty 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")))
    (fetch-and-call-with-input-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
                            (nil->empty 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 '<elpa-package>'."
  
  (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