;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;;
;;; 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 hackage)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 pretty-print)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-1)
  #:use-module ((guix download) #:select (download-to-store))
  #:use-module ((guix utils) #:select (package-name->name+version))
  #: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))
  #:export (hackage->guix-package))

;; Part 1:
;;
;; Functions used to read a cabal file and do some pre-processing: discarding
;; comments and empty lines.

;; List of libraries distributed with ghc (7.8.4).
(define ghc-standard-libraries
  '("haskell98"        ; 2.0.0.3
    "hoopl"            ; 3.10.0.1
    "base"
    "transformers"     ; 0.3.0.0
    "deepseq"          ; 1.3.0.2
    "array"            ; 0.5.0.0
    "binary"           ; 0.7.1.0
    "bytestring"       ; 0.10.4.0
    "containers"       ; 0.5.5.1
    "time"             ; 1.4.2
    "Cabal"            ; 1.18.1.5 (but not "cabal-install")
    "bin-package-db"   ; 0.0.0.0
    "ghc-prim"
    "integer-gmp"
    "Win32"            ; 2.3.0.2
    "template-haskell"
    "process"          ; 1.2.0.0
    "haskeline"        ; 0.7.1.2
    "terminfo"         ; 0.4.0.0
    "directory"        ; 1.2.1.0
    "filepath"         ; 1.3.0.2
    "old-locale"       ; 1.0.0.6
    "unix"             ; 2.7.0.1
    "old-time"         ; 1.1.0.2
    "pretty"           ; 1.1.1.1
    "xhtml"            ; 3000.2.1
    "hpc"))            ; 0.6.0.1

;; Libraries present in the "Haskell Platform" 2014.2.0 and not included in
;; the GHC standard libraries:
;;
;; "zlib"                 ; 0.5.4.1
;; "async"                ; 2.0.1.5
;; "stm"                  ; 2.4.2
;; "mtl"                  ; 2.1.3.1
;; "primitive"            ; 0.5.2.1
;; "parallel"             ; 3.2.0.4
;; "attoparsec"           ; 0.10.4.0
;; "case-insensitive"     ; 1.1.0.3
;; "syb"                  ; 0.4.1
;; "containers"           ; 0.5.5.1
;; "fgl"                  ; 5.5.0.1
;; "unordered-containers" ; 0.2.3.3
;; "hashable"             ; 1.2.1.0
;; "split"                ; 0.2.2
;; "text"                 ; 1.1.0.0
;; "vector"               ; 0.10.9.1
;; "GLURaw"               ; 1.4.0.1
;; "OpenGL"               ; 2.9.2.0
;; "OpenGLRaw"            ; 1.5.0.0
;; "GLUT"                 ; 2.5.1.1
;; "haskell-src"          ; 1.0.1.6
;; "network"              ; 2.4.2.2
;; "HTTP"                 ; 4000.2.10
;; "random"               ; 1.0.1.1
;; "HUnit"                ; 1.2.5.2
;; "QuickCheck"           ; 2.6
;; "html"                 ; 1.0.1.2
;; "parsec"               ; 3.1.5
;; "regex-compat"         ; 0.95.1
;; "regex-base"           ; 0.93.2
;; "regex-posix"          ; 0.95.2

(define guix-name-prefix "haskell-")

;; Regular expression matching "key: value"
(define key-value-rx
  "([a-zA-Z0-9-]+): *(\\w?.*)$")

;; Regular expression matching a section "head sub-head ..."
(define sections-rx
  "([a-zA-Z0-9\\(\\)-]+)")

;; Cabal comment.
(define comment-rx
  "^ *--")

;; Check if the current line includes a key
(define (has-key? line)
  (string-match key-value-rx line))

(define (comment-line? line)
  (string-match comment-rx line))

;; returns the number of indentation spaces and the rest of the line.
(define (line-indentation+rest line)
  (let loop ((line-lst (string->list line))
             (count 0))
    (if (or (null? line-lst) (not (eqv? (first line-lst) #\space)))
        (values count (list->string line-lst))
        (loop (cdr line-lst) (+ count 1)))))

;; Part 1 main function: read a cabal fila and filter empty lines and comments.
;; Returns a list composed by the pre-processed lines of the file.
(define (read-cabal port)
  (let loop ((line (read-line port))
             (result '()))
    (cond
     ((eof-object? line)
      (reverse result))
     ((or (string-null? line) (comment-line? line))
      (loop (read-line port) result))
     (else
      (loop (read-line port) (cons line result))))))

;; Part 2:
;;
;; Take the result of part 1 and convert the content of the file in a list of
;; list pairs, where the first list of the pair includes keys while the second
;; is a list of values.

;; Function to read a value split across multiple lines. LINES are the
;; remaining input lines to be read. SEED is the value read on the same line
;; as the key. Returns two values: (VALUES values-lst remaining-lines)
(define (multi-line-value lines seed)
  (if (null? lines)
      (values '() '())
      (let-values (((current-indent value) (line-indentation+rest (first lines)))
                   ((next-line-indent next-line-value)
                    (if (null? (cdr lines))
                        (values #f "")
                        (line-indentation+rest (second lines)))))
        (if (or (not next-line-indent) (< next-line-indent current-indent)
                (regexp-exec condition-rx next-line-value))
            (values (reverse (cons value seed)) (cdr lines))
            (multi-line-value (cdr lines) (cons value seed))))))

;; Parses a cabal file in the form of a list of lines as produced by
;; READ-CABAL and returns its content in the following form:
;;
;; (((head1 sub-head1 ... key1) (value))
;;  ((head2 sub-head2 ... key2) (value2))
;;  ...).
;;
;; where all elements are strings.
;;
;; We try do deduce the format from the following document:
;; https://www.haskell.org/cabal/users-guide/developing-packages.html
;;
;; Key values are case-insensitive. We therefore lowercase them. Values are
;; case-sensitive.
;;
;; Currently only only layout structured files are parsed.  Braces {}
;; structured files are not handled.
(define (cabal->key-values lines)
  (let loop
      ((lines lines)
       (indents  '()) ; only includes indents at start of section heads.
       (sections '())
       (result '()))
    (let-values
        (((current-indent line)
          (if (null? lines)
              (values 0 "")
              (line-indentation+rest (first lines))))
         ((next-line-indent next-line)
          (if (or (null? lines) (null? (cdr lines)))
              (values 0 "")
              (line-indentation+rest (second lines)))))
      (if (null? lines)
          (reverse result)
          (let ((rx-result (has-key? line)))
            (cond
             (rx-result
              (let ((key (string-downcase (match:substring rx-result 1)))
                    (value (match:substring rx-result 2)))
                (cond
                 ;; Simple single line "key: value".
                 ((= next-line-indent current-indent)
                  (loop (cdr lines) indents sections
                        (cons
                         (list (reverse (cons key sections)) (list value))
                         result)))
                 ;; Multi line "key: value\n value cont...".
                 ((> next-line-indent current-indent)
                  (let*-values (((value-lst lines)
                                 (multi-line-value (cdr lines)
                                                   (if (string-null? value)
                                                       '()
                                                       `(,value)))))
                    ;; multi-line-value returns to the first line after the
                    ;; multi-value.
                    (loop lines indents sections
                          (cons
                           (list (reverse (cons key sections)) value-lst)
                           result))))
                 ;; Section ended.
                 (else
                  ;; Indentation is reduced. Check by how many levels.
                  (let*-values (((idx) (+ (list-index
                                           (lambda (x) (= next-line-indent x))
                                           indents)
                                          (if (has-key? next-line) 1 0)))
                                ((_ sec) (split-at sections idx))
                                ((_ ind) (split-at indents idx)))
                    (loop (cdr lines) ind sec
                          (cons 
                           (list (reverse (cons key sections)) (list value))
                           result)))))))
             ;; Start of a new section.
             ((or (null? indents)
                  (> current-indent (first indents)))
              (loop (cdr lines) (cons current-indent indents)
                    (cons (string-downcase line) sections) result))
             (else
              (loop (cdr lines) indents
                    (cons (string-downcase line) (cdr sections))
                    result))))))))

;; Find if a string represent a conditional
(define condition-rx
  (make-regexp "^if +(.*)$"))

;; Split sections in individual words with exception for the predicate of an
;; 'if' conditional.
(define (split-section section)
  (let ((rx-result (regexp-exec condition-rx section)))
    (if rx-result
        `("if" ,(match:substring rx-result 1))
        (map match:substring (list-matches sections-rx section)))))

(define (join-sections sec1 sec2)
  (fold-right cons sec2 sec1))

(define (pre-process-keys key)
  (match key
    (() '())
    ((sec1 rest ...)
     (join-sections (split-section sec1) (pre-process-keys rest)))))

(define (pre-process-entry-keys entry)
  (match entry
    ((key value)
     (list (pre-process-keys key) value))
    (() '())))

;; Split all strings included in the list of keys into individual words, with
;; exception for 'if' predicates. Returns an entry with the key list composed
;; by single words. This is used to read flags.
(define (pre-process-entries-keys entries)
  (match entries
    ((entry rest ...)
     (cons (pre-process-entry-keys entry)
           (pre-process-entries-keys rest)))
    (()
     '())))

;; Read flags and returns an alist where each pair is composed by the name of
;; a flag and its value: "True" or "False".
(define (get-flags pre-processed-entries)
  (match pre-processed-entries
    (() '())
    (((("flag" flag-name "default") (flag-val)) rest ...)
     (cons (cons flag-name  flag-val)
           (get-flags rest)))
    ((entry rest ... )
     (get-flags rest))
    (_ #f)))

;; Part 3:
;;
;; So far we did read the cabal file and extracted flags information. Now we
;; need to evaluate the conditions and process the entries accordingly.

;; Cabal test keywords
(define tests-rx
  (make-regexp "(os|arch|flag|impl)\\(([a-zA-Z0-9_-]+)\\)"))

;; Parentheses within conditions
(define parens-rx
  (make-regexp "\\((.+)\\)"))

;; OR operator in conditions
(define or-rx
  (make-regexp " +\\|\\| +"))

;; AND operator in conditions
(define and-rx
  (make-regexp " +&& +"))

;; NOT operator in conditions
(define not-rx
  (make-regexp "^!.+"))

;; Returns a list with the arguments of (logic) bianry operators.  MATCH-LST
;; is the result of "list-match" against a binary operator regexp.
(define (bi-op-args str match-lst)
  (let ((operators (length match-lst)))
    (map (lambda (from to)
           (substring str from to))
         (cons 0 (map match:end match-lst))
         (append (map match:start match-lst) (list (string-length str))))))

;; If there is a single argument there is no binary operation to perform. We
;; just return the argument. Takes a list as produced by
;; "bi-op-argsf". Returns a string.
(define (bi-op->sexp-like bi-op args)
  (if (= (length args) 1)
      (first args)
      (string-append "(" bi-op
                     (fold (lambda (arg seed) (string-append seed " " arg))
                           "" args) ")")))

;; Takes a string and checks for negation symbol.
(define (not->sexp-like arg)
  (if (regexp-exec not-rx arg)
      (string-append "(not "
                     (substring arg 1 (string-length arg))
                     ")")
      arg))

;; Convert a CABAL conditional string into a string with equivalent SCHEME
;; syntax.  This procedure accepts only simple conditionals without
;; parentheses.
(define (parens-less-cond->sexp-like conditional)
  ;; The outher operation is the one with the lowest priority: OR
  (bi-op->sexp-like
   "or"
   ;; each OR argument may be an AND operation
   (map (lambda (or-arg)
          (let ((m-lst (list-matches and-rx or-arg)))
            ;; is there an AND operation?
            (if (> (length m-lst) 0)
                (bi-op->sexp-like
                 "and"
                 ;; expand NOT operators when there are ANDs
                 (map not->sexp-like (bi-op-args or-arg m-lst)))
                ;; ... and when there aren't.
                (not->sexp-like or-arg))))
        ;; list of OR arguments
        (bi-op-args conditional (list-matches or-rx conditional)))))

(define test-keyword-ornament "§§")

;; Convert a CABAL conditional string into a string with equivalent SCHEME
;; syntax.
(define (conditional->sexp-like conditional)
  ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests
  ;; keywords so that parentheses are only used to set precedences. This
  ;; substantially simplify parsing.
  (let ((conditional
         (regexp-substitute/global #f tests-rx conditional
                                   'pre 1 test-keyword-ornament 2
                                   test-keyword-ornament 'post)))
    (let loop ((sub-cond conditional))
      (let ((rx-result (regexp-exec parens-rx sub-cond)))
        (cond
         (rx-result
          (parens-less-cond->sexp-like
           (string-append
            (match:prefix rx-result)
            (loop (match:substring rx-result 1))
            (match:suffix rx-result))))
         (else
          (parens-less-cond->sexp-like sub-cond)))))))

;; Substitute SCHEME #t or #f according to the value of flags. (Default to
;; "True")
(define (eval-flags sexp-like-cond flags)
  (fold-right
   (lambda (flag sexp)
     (match flag
       ((name . value)
        (let ((rx (make-regexp
                   (string-append "flag" test-keyword-ornament name
                                  test-keyword-ornament))))
          (regexp-substitute/global
           #f rx sexp
           'pre (if (string-ci= value "False") "#f" "#t") 'post)))
       (_ sexp)))
   sexp-like-cond
   (cons '("[a-zA-Z0-9_-]+" . "True") flags)))

;; We need to substitute test keywords "os(...)" and "arch(...)" with
;; S-expression functions that perform the check when we want to build the
;; package.
;;
;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux".
(define (eval-tests sexp-like-cond)
  (with-input-from-string 
      (fold-right
       (lambda (test sexp)
         (match test
           ((type pre-match post-match)
            (let ((rx (make-regexp
                       (string-append type test-keyword-ornament "(\\w+)"
                                      test-keyword-ornament))))
              (regexp-substitute/global
               #f rx sexp
               'pre pre-match 2 post-match 'post)))
           (_ sexp)))
       sexp-like-cond
       '(("(os|arch)" "(string-match \"" "\" (%current-system))")))
    read))

;; We check for the cabal test "impl(...)".  Assume the module declaring the
;; generated package includes a local variable called "haskell-implementation"
;; with a value of the form NAME-VERSION against which we compare.
(define (eval-impl sexp-like-cond)
  (with-output-to-string
    (lambda ()
      (write
       (with-input-from-string 
           (fold-right
            (lambda (test sexp)
              (match test
                ((pre-match post-match)
                 (let ((rx-with-version
                        (make-regexp
                         (string-append
                          "impl" test-keyword-ornament
                          "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *"
                          test-keyword-ornament)))
                       (rx-without-version
                        (make-regexp
                         (string-append "impl" test-keyword-ornament "(\\w+)"
                                        test-keyword-ornament))))
                   (if (regexp-exec rx-with-version sexp)
                       (regexp-substitute/global
                        #f rx-with-version sexp
                        'pre pre-match 2 " \"" 1 "-" 3 "\" " post-match 'post)
                       (regexp-substitute/global
                        #f rx-without-version sexp
                        'pre pre-match "-match \"" 1 "\" " post-match 'post))))
                (_ sexp)))
            sexp-like-cond
            '(("(string" "haskell-implementation)")))
         read)))))

;; META is the result of "cabal->key-values". Returns the list associated with
;; a specific KEY.  Since the value can be a list (as for "description"), we
;; always return a list.
(define (key->values meta key)
  (match meta
    (() '())
    (((((? (lambda(x) (equal? x key)))) v) r ...)
     v)
    (((k v) r ...)
     (key->values (cdr meta) key))
    (_ "key Not fount")))

;; Returns all entries with a key starting with key-start and ending with
;; key-end as in (key-start ... key-end).
(define (key-start-end->entries meta key-start key-end)
  (let ((pred
         (lambda (x)
           (equal? (list key-start key-end) (list (first x) (last x))))))
    (match meta
      (() '())
      ((((? pred k) v) r ...)
       (cons `(,k ,v) (key-start-end->entries (cdr meta) key-start key-end)))
      (((k v) r ...)
       (key-start-end->entries (cdr meta) key-start key-end))
      (_ "key Not fount"))))

(define else-rx
  (make-regexp "^else$"))

(define (count-if-else rx-result-ls)
  (apply + (map (lambda (m) (if m 1 0)) rx-result-ls)))

(define (analyze-entry-cond entry)
  (let* ((keys (first entry))
         (vals (second entry))
         (rx-cond-result
          (map (cut regexp-exec condition-rx <>) keys))
         (rx-else-result
          (map (cut regexp-exec else-rx <>) keys))
         (cond-no (count-if-else rx-cond-result))
         (else-no (count-if-else rx-else-result))
         (cond-idx (list-index (lambda (rx) (if rx #t #f)) rx-cond-result))
         (else-idx (list-index (lambda (rx) (if rx #t #f)) rx-else-result))
         (key-cond
              (cond
               ((or (and cond-idx else-idx (< cond-idx else-idx))
                    (and cond-idx (not else-idx)))
                (match:substring
                 (receive (head tail)
                     (split-at rx-cond-result cond-idx) (first tail))))
               ((or (and cond-idx else-idx (> cond-idx else-idx))
                    (and (not cond-idx) else-idx))
                (match:substring
                 (receive (head tail)
                     (split-at rx-else-result else-idx) (first tail))))
               (else
                ""))))
    (values keys vals rx-cond-result
            rx-else-result cond-no else-no key-cond)))

(define (remove-cond entry cond)
  (match entry
    ((k v)
     (list (cdr (member cond k)) v))))

(define (group-and-reduce-level entries group group-cond)
  (let loop
      ((true-group group)
       (false-group '())
       (entries entries))
    (if (null? entries)
        (values (reverse true-group) (reverse false-group) entries)
        (let*-values (((entry) (first entries))
                      ((keys vals rx-cond-result rx-else-result
                             cond-no else-no key-cond)
                       (analyze-entry-cond entry)))
          (cond
           ((and (>= (+ cond-no else-no) 1) (string= group-cond key-cond))
            (loop (cons (remove-cond entry group-cond) true-group) false-group
                  (cdr entries)))
           ((and (>= (+ cond-no else-no) 1) (string= key-cond "else"))
            (loop true-group (cons (remove-cond entry "else") false-group)
                  (cdr entries)))
           (else
            (values (reverse true-group) (reverse false-group) entries)))))))

(define dependencies-rx
  (make-regexp "([a-zA-Z0-9_-]+) *[^,]*,?"))

(define (guix-name name)
  (if (string-prefix? guix-name-prefix name)
      (string-downcase name)
      (string-append guix-name-prefix (string-downcase name))))

;; Split the comma separated list of dependencies coming from the cabal file
;; and return a list with inputs suitable for the GUIX package.  Currently the
;; version information is discarded.
(define (split-dependencies ls)
  (define (split-at-comma d)
    (map
     (lambda (m)
       (let ((name (guix-name (match:substring m 1))))
         (list name (list 'unquote (string->symbol name)))))
     (list-matches dependencies-rx d)))
    
  (fold (lambda (d p) (append (split-at-comma d) p)) '()  ls))

;; Genrate an S-expression containing the list of dependencies.  The generated
;; S-expressions may include conditionals as defined in the cabal file.
;; During this process we discard the version information of the packages.
(define (dependencies-cond->sexp meta)

  (define (take-dependencies meta)
    (let ((key-start-exe "executable cabal")
          (key-start-lib "library")
          (key-end "build-depends"))
      (append
       (key-start-end->entries meta key-start-exe key-end)
       (key-start-end->entries meta key-start-lib key-end))))

  (let ((flags (get-flags (pre-process-entries-keys meta))))
    (delete-duplicates
     (let loop ((entries (take-dependencies meta))
                (result '()))
       (if (null? entries)
           result
           (let*-values (((entry) (first entries))
                         ((keys vals rx-cond-result rx-else-result
                                cond-no else-no key-cond)
                          (analyze-entry-cond entry)))
             (cond
              ((= (+ cond-no else-no) 0)
               (loop (cdr entries) (append (split-dependencies vals) result)))
              (else
               (let-values (((true-group false-group entries)
                             (group-and-reduce-level entries '()
                                                     key-cond))
                            ((cond-final) (eval-tests
                                           (eval-impl
                                            (eval-flags
                                             (conditional->sexp-like
                                              (last (split-section key-cond)))
                                             flags)))))
                 (loop entries
                       (cond
                        ((or (eq? cond-final #t) (equal? cond-final '(not #f)))
                         (append (loop true-group '()) result))
                        ((or (eq? cond-final #f) (equal? cond-final '(not #t)))
                         (append (loop false-group '()) result))
                        (else
                         (cons `(unquote-splicing
                                 (if ,cond-final
                                     ,(loop true-group '())
                                     ,(loop false-group '())))
                               result)))))))))))))

;; Filter the libraries already included in the Haskell compiler standard
;; libraries. Currently we imply the use of GHC.
(define (filter-standard-libraries ls)
  (let ((real-name-rx (make-regexp
                       (string-append guix-name-prefix "(\\w+)"))))
    (fold (lambda (elem seed)
            (if (eq? (first elem) 'unquote-splicing)
                (let*-values (((group-cond true-group false-group)
                               (match (second elem)
                                 ((if c t f )
                                  (values c t f))
                                 (_ (values c '() '()))))
                              ((filtered-true-group)
                               (filter-standard-libraries true-group))
                              ((filtered-false-group)
                               (filter-standard-libraries false-group)))
                  (cond
                   ((and (null? filtered-false-group)
                         (null? filtered-true-group))
                    seed)
                   ((null? filtered-false-group)
                    (cons (list 'unquote-splicing
                                (list 'if group-cond 
                                      filtered-true-group))
                          seed))
                   (else
                    (cons (list 'unquote-splicing
                                (list 'if group-cond
                                      filtered-true-group
                                      filtered-false-group))
                          seed))))
                (let ((rx-result (regexp-exec real-name-rx (first elem))))
                  (match (match:substring rx-result 1)
                    ((? (cut member <>
                             ;; GUIX names are all lower-case.
                             (map (cut string-downcase <>)
                                  ghc-standard-libraries)))
                     seed)
                    (_
                     (cons elem seed))))))
          '() ls)))

;; Part 4:
;;
;; Retrive the desired package and its cabal file from
;; http://hackage.haskell.org and construct the GUIX package S-expression.

(define (hackage-fetch name-version)
  "Return the cabal file for the package NAME-VERSION, or #f on failure.  If
the version part is omitted from the package name, then return the latest
version."
  (let*-values (((name version) (package-name->name+version name-version))
                ((url)
                 (if version
                     (string-append "http://hackage.haskell.org/package/"
                                    name "-" version "/" name ".cabal")
                     (string-append "http://hackage.haskell.org/package/"
                                    name "/" name ".cabal")))
                ((cabal) 
                 (call-with-temporary-output-file
                  (lambda (temp port)
                    (and (url-fetch url temp)
                         (call-with-input-file temp read-cabal))))))
    (and=> cabal cabal->key-values)))

;; List of valid values from
;; https://www.haskell.org
;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html.
(define string->license
  (match-lambda
   ("GPL-2" 'gpl2)
   ("GPL-3" 'gpl3)
   ("GPL" "'gpl??")
   ("AGPL-3" 'agpl3)
   ("AGPL" "'agpl??")
   ("LGPL-2.1" 'lgpl2.1)
   ("LGPL-3" 'lgpl3)
   ("LGPL" "'lgpl??")
   ("BSD2" 'bsd-2)
   ("BSD3" 'bsd-3)
   ("MIT" 'expat)
   ("ISC" 'isc)
   ("MPL" 'mpl2.0)
   ("Apache-2.0" 'asl2.0)
   ((x) (string->license x))
   ((lst ...) `(list ,@(map string->license lst)))
   (_ #f)))

(define (hackage-module->sexp meta)
  "Return the `package' s-expression for a cabal package from the metadata in
META."

  (define name
    (first (key->values meta "name")))

  (define version
    (first (key->values meta "version")))
  
  (define description
    (let*-values (((description) (key->values meta "description"))
                  ((lines last)
                   (split-at description (- (length description) 1))))
      (fold-right (lambda (line seed) (string-append line "\n" seed))
                  (first last) lines)))
  
  (define source-url
    (string-append "http://hackage.haskell.org/package/" name
                   "/" name "-" version ".tar.gz"))

  (define (maybe-inputs guix-name inputs)
    (match (filter-standard-libraries inputs)
      (()
       '())
      ((inputs ...)
       (list (list guix-name
                   (list 'quasiquote inputs))))))
  
  (let ((tarball (with-store store
                   (download-to-store store source-url))))
    `(package
       (name ,(guix-name name))
       (version ,version)
       (source (origin
                 (method url-fetch)
                 (uri (string-append ,@(factorize-uri source-url version)))
                 (sha256
                  (base32
                   ,(bytevector->nix-base32-string (file-sha256 tarball))))))
       (build-system haskell-build-system)
       ,@(maybe-inputs 'inputs (dependencies-cond->sexp meta))
       (home-page ,@(key->values meta "homepage"))
       (synopsis ,@(key->values meta "synopsis"))
       (description ,description)
       (license ,(string->license (key->values meta "license"))))))

(define (hackage->guix-package module-name)
  "Fetch the cabal file for PACKAGE-NAME from hackage.haskell.org, and return
the `package' s-expression corresponding to that package, or #f on failure."
  (let ((module-meta (hackage-fetch module-name)))
    (and=> module-meta hackage-module->sexp)))

;; Part 5:
;;
;; Some variables used to test the varisous functions.

(define test-1
  '("head 1"
    "  kh1: vh1"
    "  kh2: vh2"
    "name: mtl"))

(define test-2
  '("head 1"
    "  subh 1"
    "   kh1: vh1"
    "   kh2: vh2"
    "name: mtl"))

(define test-3
  '("head 1"
    "  subh 1"
    "   kh1: vh1"
    "  subh 2"
    "   kh2: vh2"
    "   kh3: vh3"
    "name: mtl"))

(define test-4
  '("Library"
    "  Build-Depends:   basee"
    "  Exposed-Modules: Testing.Test1"
    "  Extensions:      CPP"
    "  if flag(debug)"
    "    GHC-Options: -DDEBUG"
    "    if !os(windows)"
    "      CC-Options: \"-DDEBUG\""
    "    else"
    "      CC-Options: \"-DNDEBUG else\""
    "  if flag(webfrontend)"
    "    Build-Depends: cgi > 0.42"
    "    Other-Modules: Testing.WebStuff"))

(define test-5
  '("Flag Debug"
    "  Description: Enable debug support"
    "  Default:     False"
    "Library"
    "  Build-Depends:   base"
    "  if flag(debug)"
    "    GHC-Options: -DDEBUG"
    "    if !os(windows)"
    "      CC-Options: \"-DDEBUG\""
    "    else"
    "      CC-Options: \"-DNDEBUG\""))

(define test-6
  '("Flag Debug"
    "  Description: Enable debug support"
    "  Default:     False"
    "Flag Cips"
    "  Description:   This is a journey into the sound..."
    "  Default:     True"
    "if flag(debug)"
    "  GHC-Options: -DDEBUG"
    "  if !os(windows)"
    "    CC-Options: \"-DDEBUG\""
    "  else"
    "    CC-Options: \"-DNDEBUG\""))

(define test-7
  '("executable cabal"
    "  main-is:        Main.hs"
    "  build-depends:"
    "    array      >= 0.1      && < 0.6,"
    "    base       >= 4.3      && < 5"
    "    if flag(old-directory)"
    "      build-depends: directory >= 1 && < 1.2, old-time >= 1 && < 1.2,"
    "                     process   >= 1.0.1.1  && < 1.1.0.2"
    "    else"
    "      build-depends: directory >= 1.2 && < 1.3,"
    "                     process   >= 1.1.0.2  && < 1.3"
    "    if flag(network-uri)"
    "      build-depends: network-uri >= 2.6, network >= 2.6"
    "    else"
    "      build-depends: network     >= 2.4 && < 2.6"
    "    if os(windows)"
    "      build-depends: Win32 >= 2 && < 3"
    "      cpp-options: -DWIN32"
    "    else"
    "      build-depends: unix >= 2.0 && < 2.8"))

(define test-dep-1
  '((("executable cabal" "build-depends")
     ("array      >= 0.1"))
    (("executable cabal" "build-depends")
     ("fbe      >= 0.2"))))

(define test-dep-2
  '((("executable cabal" "if flag(cips)" "build-depends")
     ("fbe      >= 0.2"))))

(define test-dep-3
  '((("executable cabal" "if flag(cips)" "build-depends")
     ("fbe      >= 0.2"))
    (("executable cabal" "else" "build-depends")
     ("fbeee      >= 0.3"))
    ))

(define test-dep-4
  '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends")
     ("network-uri >= 2.6, network >= 2.6"))
    (("executable cabal" "if flag(a)" "else" "build-depends")
     ("fbeeeee      >= 0.3"))
    (("executable cabal" "build-depends")
     ("network      >= 0.1"))
    ))

(define test-dep-5
  '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends")
     ("fbe      >= 0.2"))
    (("executable cabal" "if flag(a)" "else" "build-depends")
     ("fbe      >= 0.3"))
    (("executable cabal" "else" "build-depends")
     ("fbe      >= 0.4"))
    ))

(define test-dep-6
  '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends")
     ("fbe      >= 0.2"))
    (("executable cabal" "if flag(a)" "else" "build-depends")
     ("fbe      >= 0.3"))
    (("executable cabal" "else" "build-depends")
     ("fbe      >= 0.4"))
    (("executable cabal" "build-depends")
     ("array      >= 0.1"))
        ))

(define test-dep-10
  '((("executable cabal" "build-depends")
     ("array      >= 0.1      && < 0.6," "base       >= 4.3      && < 5"))
    (("executable cabal" "if flag(old-directory)" "build-depends")
     ("directory >= 1 && < 1.2," "process   >= 1.0.1.1  && < 1.1.0.2"))
    (("executable cabal" "else" "build-depends")
     ("directory >= 1.2 && < 1.3," "process   >= 1.1.0.2  && < 1.3"))
    (("executable cabal" "if flag(network-uri)" "build-depends")
     ("network-uri >= 2.6, network >= 2.6"))
    (("executable cabal" "else" "build-depends")
     ("network     >= 2.4 && < 2.6"))
    (("executable cabal" "if os(windows)" "build-depends")
     ("Win32 >= 2 && < 3"))
    (("executable cabal" "else" "build-depends")
     ("unix >= 2.0 && < 2.8"))))

(define test-dep-10a
  '((("executable cabal" "build-depends")
     ("array      >= 0.1      && < 0.6," "base       >= 4.3      && < 5"))
    (("executable cabal" "if flag(old-directory)" "build-depends")
     ("directory >= 1 && < 1.2, old-time >= 1 && < 1.2"))
    (("executable cabal" "else" "build-depends")
     ("directory >= 1.2 && < 1.3," "process   >= 1.1.0.2  && < 1.3"))
    (("executable cabal" "if flag(network-uri)" "build-depends")
     ("network-uri >= 2.6, network >= 2.6"))
    (("executable cabal" "else" "build-depends")
     ("network     >= 2.4 && < 2.6"))
    (("executable cabal" "if os(windows)" "build-depends")
     ("Win32 >= 2 && < 3"))
    (("executable cabal" "else" "build-depends")
     ("unix >= 2.0 && < 2.8"))))

(define test-dep-11
  '((("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "build-depends")
     ("network-uri >= 2.6, network >= 2.6"))
    (("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "if flag(cips)" "build-depends")
     ("network-uri >= 2.6, network >= 2.6"))
    (("executable cabal" "if flag(old-directory)" "else" "build-depends")
     ("network     >= 2.4 && < 2.6"))
    (("executable cabal" "else" "build-depends")
     ("directory >= 1.2 && < 1.3," "process   >= 1.1.0.2  && < 1.3"))
    (("executable cabal" "else" "if flag(cips)" "build-depends")
     ("cip >= 1.2"))))

(define test-dep-12
  '((("executable cabal" "build-depends")
     ("array      >= 0.1      && < 0.6," "base       >= 4.3      && < 5"))
    (("executable cabal" "if flag(old-directory)" "build-depends")
     ("directory >= 1 && < 1.2," "process   >= 1.0.1.1  && < 1.1.0.2"))
    (("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "build-depends")
     ("network-uri >= 2.6, network >= 2.6"))
    (("executable cabal" "if flag(old-directory)" "else" "build-depends")
     ("network     >= 2.4 && < 2.6"))
    (("executable cabal" "else" "build-depends")
     ("directory >= 1.2 && < 1.3," "process   >= 1.1.0.2  && < 1.3"))))

(define test-dep-13
  '((("executable cabal" "if os(linux)" "if flag(debug)" "build-depends")
     ("network-uri >= 2.6, network >= 2.6"))
    (("executable cabal" "if os(linux)" "if flag(debug)" "if flag(cips)" "build-depends")
     ("network-uri >= 2.6, network >= 2.6"))
    (("executable cabal" "if os(linux)" "else" "build-depends")
     ("network     >= 2.4 && < 2.6"))
    (("executable cabal" "else" "build-depends")
     ("directory >= 1.2 && < 1.3," "process   >= 1.1.0.2  && < 1.3"))
    (("executable cabal" "else" "if flag(cips)" "build-depends")
     ("cip >= 1.2"))))

(define test-cond-1
  "(os(darwin) && !(arch(i386))) || os(freebsd)")

(define test-cond-2
  "(os(darwin) || !(arch(i386))) && os(freebsd)")

(define test-cond-3
  "os(darwin) && arch(i386) || os(freebsd)")

(define test-cond-4
  "os(darwin) && !arch(i386) || !os(freebsd)")

(define test-cond-5
  "os(darwin) && !arch(i386) && !os(freebsd)")

(define test-cond-6
  "(os(darwin) || !(flag(debug))) && flag(cips)")

(define test-cond-7
  "(os(darwin) || !(flag(debug))) && flag(cips) && flag(fbe)")

(define test-cond-8
  "os(linux) && impl(ghc)")

(define test-cond-9
  "os(linux) && impl(ghc <= 6.1.0)")

;; Run some tests

;; (display (cabal->key-values
;;           (call-with-input-file "mtl.cabal" read-cabal)))
;; (display (cabal->key-values
;;           (call-with-input-file "/home/beffa/tmp/cabal-install.cabal" read-cabal)))
;; (display (get-flags (pre-process-entries-keys (cabal->key-values test-5))))
;; (newline)
;; (display (conditional->sexp-like test-cond-2))
;; (newline)
;; (display
;;  (eval-flags (conditional->sexp-like test-cond-6)
;;              (get-flags (pre-process-entries-keys (cabal->key-values test-6)))))
;; (newline)
;; (key->values (cabal->key-values test-1) "name")
;; (newline)
;; (key-start-end->entries (cabal->key-values test-4) "Library" "CC-Options")
;; (newline)
;; (eval-tests (conditional->sexp-like test-cond-6))
;;
;;; cabal.scm ends here