guix/import/hackage.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
   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 hackage)
  20   #:use-module (ice-9 match)
  21   #:use-module (ice-9 regex)
  22   #:use-module (ice-9 rdelim)
  23   #:use-module (ice-9 receive)
  24   #:use-module (ice-9 pretty-print)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (srfi srfi-34)
  27   #:use-module (srfi srfi-35)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-1)
  30   #:use-module ((guix download) #:select (download-to-store))
  31   #:use-module ((guix utils) #:select (package-name->name+version))
  32   #:use-module (guix import utils)
  33   #:use-module (guix store)
  34   #:use-module (guix hash)
  35   #:use-module (guix base32)
  36   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  37   #:export (hackage->guix-package))
  38
  39 ;; Part 1:
  40 ;;
  41 ;; Functions used to read a Cabal file.
  42
  43 (define ghc-standard-libraries
  44   ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as
  45   ;; some packages list it.
  46   '("ghc"
  47     "haskell98"
  48     "hoopl"
  49     "base"
  50     "transformers"
  51     "deepseq"
  52     "array"
  53     "binary"
  54     "bytestring"
  55     "containers"
  56     "time"
  57     "cabal"
  58     "bin-package-db"
  59     "ghc-prim"
  60     "integer-gmp"
  61     "integer-simple"
  62     "win32"
  63     "template-haskell"
  64     "process"
  65     "haskeline"
  66     "terminfo"
  67     "directory"
  68     "filepath"
  69     "old-locale"
  70     "unix"
  71     "old-time"
  72     "pretty"
  73     "xhtml"
  74     "hpc"))
  75
  76 (define package-name-prefix "ghc-")
  77
  78 (define key-value-rx
  79   ;; Regular expression matching "key: value"
  80   (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$"))
  81
  82 (define sections-rx
  83   ;; Regular expression matching a section "head sub-head ..."
  84   (make-regexp "([a-zA-Z0-9\\(\\)-]+)"))
  85
  86 (define comment-rx
  87   ;; Regexp matching Cabal comment lines.
  88   (make-regexp "^ *--"))
  89
  90 (define (has-key? line)
  91   "Check if LINE includes a key."
  92   (regexp-exec key-value-rx line))
  93
  94 (define (comment-line? line)
  95   "Check if LINE is a comment line."
  96   (regexp-exec comment-rx line))
  97
  98 (define (line-indentation+rest line)
  99   "Returns two results: The number of indentation spaces and the rest of the
 100 line (without indentation)."
 101   (let loop ((line-lst (string->list line))
 102              (count 0))
 103     ;; Sometimes values are spread over multiple lines and new lines start
 104     ;; with a comma ',' with the wrong indentation.  See e.g. haddock-api.
 105     (if (or (null? line-lst)
 106             (not (or
 107                   (eqv? (first line-lst) #\space)
 108                   (eqv? (first line-lst) #\,) ; see, e.g., haddock-api.cabal
 109                   (eqv? (first line-lst) #\tab))))
 110         (values count (list->string line-lst))
 111         (loop (cdr line-lst) (+ count 1)))))
 112
 113 (define (multi-line-value lines seed)
 114   "Function to read a value split across multiple lines. LINES are the
 115 remaining input lines to be read. SEED is the value read on the same line as
 116 the key.  Return two values: A list with values and the remaining lines to be
 117 processed."
 118   (define (multi-line-value-with-min-indent lines seed min-indent)
 119     (if (null? lines)
 120         (values '() '())
 121         (let-values (((current-indent value) (line-indentation+rest (first lines)))
 122                      ((next-line-indent next-line-value)
 123                       (if (null? (cdr lines))
 124                           (values #f "")
 125                           (line-indentation+rest (second lines)))))
 126           (if (or (not next-line-indent) (< next-line-indent min-indent)
 127                   (regexp-exec condition-rx next-line-value))
 128               (values (reverse (cons value seed)) (cdr lines))
 129               (multi-line-value-with-min-indent (cdr lines) (cons value seed)
 130                                                 min-indent)))))
 131
 132   (let-values (((current-indent value) (line-indentation+rest (first lines))))
 133     (multi-line-value-with-min-indent lines seed current-indent)))
 134
 135 (define (read-cabal port)
 136   "Parses a Cabal file from PORT.  Return a list of list pairs:
 137
 138 (((head1 sub-head1 ... key1) (value))
 139  ((head2 sub-head2 ... key2) (value2))
 140  ...).
 141
 142 We try do deduce the Cabal format from the following document:
 143 https://www.haskell.org/cabal/users-guide/developing-packages.html
 144
 145 Keys are case-insensitive.  We therefore lowercase them.  Values are
 146 case-sensitive.  Currently only indentation-structured files are parsed.
 147 Braces structured files are not handled." ;" <- make emacs happy.
 148   (define (read-and-trim-line port)
 149     (let ((line (read-line port)))
 150       (if (string? line)
 151           (string-trim-both line #\return)
 152           line)))
 153
 154   (define (strip-insignificant-lines port)
 155     (let loop ((line (read-and-trim-line port))
 156                (result '()))
 157       (cond
 158        ((eof-object? line)
 159         (reverse result))
 160        ((or (string-null? line) (comment-line? line))
 161         (loop (read-and-trim-line port) result))
 162        (else
 163         (loop (read-and-trim-line port) (cons line result))))))
 164
 165   (let loop
 166       ((lines (strip-insignificant-lines port))
 167        (indents  '()) ; only includes indents at start of section heads.
 168        (sections '())
 169        (result '()))
 170     (let-values
 171         (((current-indent line)
 172           (if (null? lines)
 173               (values 0 "")
 174               (line-indentation+rest (first lines))))
 175          ((next-line-indent next-line)
 176           (if (or (null? lines) (null? (cdr lines)))
 177               (values 0 "")
 178               (line-indentation+rest (second lines)))))
 179       (if (null? lines)
 180           (reverse result)
 181           (let ((rx-result (has-key? line)))
 182             (cond
 183              (rx-result
 184               (let ((key (string-downcase (match:substring rx-result 1)))
 185                     (value (match:substring rx-result 2)))
 186                 (cond
 187                  ;; Simple single line "key: value".
 188                  ((= next-line-indent current-indent)
 189                   (loop (cdr lines) indents sections
 190                         (cons
 191                          (list (reverse (cons key sections)) (list value))
 192                          result)))
 193                  ;; Multi line "key: value\n value cont...".
 194                  ((> next-line-indent current-indent)
 195                   (let*-values (((value-lst lines)
 196                                  (multi-line-value (cdr lines)
 197                                                    (if (string-null? value)
 198                                                        '()
 199                                                        `(,value)))))
 200                     ;; multi-line-value returns to the first line after the
 201                     ;; multi-value.
 202                     (loop lines indents sections
 203                           (cons
 204                            (list (reverse (cons key sections)) value-lst)
 205                            result))))
 206                  ;; Section ended.
 207                  (else
 208                   ;; Indentation is reduced. Check by how many levels.
 209                   (let* ((idx (and=> (list-index
 210                                       (lambda (x) (= next-line-indent x))
 211                                       indents)
 212                                      (cut + <>
 213                                             (if (has-key? next-line) 1 0))))
 214                          (sec
 215                           (if idx
 216                               (drop sections idx)
 217                               (raise
 218                                (condition
 219                                 (&message
 220                                  (message "unable to parse Cabal file"))))))
 221                          (ind (drop indents idx)))
 222                     (loop (cdr lines) ind sec
 223                           (cons
 224                            (list (reverse (cons key sections)) (list value))
 225                            result)))))))
 226              ;; Start of a new section.
 227              ((or (null? indents)
 228                   (> current-indent (first indents)))
 229               (loop (cdr lines) (cons current-indent indents)
 230                     (cons (string-downcase line) sections) result))
 231              (else
 232               (loop (cdr lines) indents
 233                     (cons (string-downcase line) (cdr sections))
 234                     result))))))))
 235
 236 (define condition-rx
 237   ;; Regexp for conditionals.
 238   (make-regexp "^if +(.*)$"))
 239
 240 (define (split-section section)
 241   "Split SECTION in individual words with exception for the predicate of an
 242 'if' conditional."
 243   (let ((rx-result (regexp-exec condition-rx section)))
 244     (if rx-result
 245         `("if" ,(match:substring rx-result 1))
 246         (map match:substring (list-matches sections-rx section)))))
 247
 248 (define (join-sections sec1 sec2)
 249   (fold-right cons sec2 sec1))
 250
 251 (define (pre-process-keys key)
 252   (match key
 253     (() '())
 254     ((sec1 rest ...)
 255      (join-sections (split-section sec1) (pre-process-keys rest)))))
 256
 257 (define (pre-process-entry-keys entry)
 258   (match entry
 259     ((key value)
 260      (list (pre-process-keys key) value))
 261     (() '())))
 262
 263 (define (pre-process-entries-keys entries)
 264   "ENTRIES is a list of list pairs, a keys list and a valules list, as
 265 produced by 'read-cabal'.  Split each element of the keys list into individual
 266 words.  This pre-processing is used to read flags."
 267   (match entries
 268     ((entry rest ...)
 269      (cons (pre-process-entry-keys entry)
 270            (pre-process-entries-keys rest)))
 271     (()
 272      '())))
 273
 274 (define (get-flags pre-processed-entries)
 275   "PRE-PROCESSED-ENTRIES is a list of list pairs, a keys list and a values
 276 list, as produced by 'read-cabal' and pre-processed by
 277 'pre-process-entries-keys'.  Return a list of pairs with the name of flags and
 278 their default value (one of \"False\" or \"True\") as specified in the Cabal file:
 279
 280 ((\"flag1-name\" . \"False-or-True\") ...)." ;" <- make emacs happy
 281   (match pre-processed-entries
 282     (() '())
 283     (((("flag" flag-name "default") (flag-val)) rest ...)
 284      (cons (cons flag-name  flag-val)
 285            (get-flags rest)))
 286     ((entry rest ... )
 287      (get-flags rest))
 288     (_ #f)))
 289
 290 ;; Part 2:
 291 ;;
 292 ;; Functions to read information from the Cabal object created by 'read-cabal'
 293 ;; and convert Cabal format dependencies conditionals into equivalent
 294 ;; S-expressions.
 295
 296 (define tests-rx
 297   ;; Cabal test keywords
 298   (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)"))
 299
 300 (define parens-rx
 301   ;; Parentheses within conditions
 302   (make-regexp "\\((.+)\\)"))
 303
 304 (define or-rx
 305   ;; OR operator in conditions
 306   (make-regexp " +\\|\\| +"))
 307
 308 (define and-rx
 309   ;; AND operator in conditions
 310   (make-regexp " +&& +"))
 311
 312 (define not-rx
 313   ;; NOT operator in conditions
 314   (make-regexp "^!.+"))
 315
 316 (define (bi-op-args str match-lst)
 317   "Return a list with the arguments of (logic) bianry operators.  MATCH-LST
 318 is the result of 'list-match' against a binary operator regexp on STR."
 319   (let ((operators (length match-lst)))
 320     (map (lambda (from to)
 321            (substring str from to))
 322          (cons 0 (map match:end match-lst))
 323          (append (map match:start match-lst) (list (string-length str))))))
 324
 325 (define (bi-op->sexp-like bi-op args)
 326   "BI-OP is a string with the name of a Scheme operator which in a Cabal file
 327 is represented by a binary operator.  ARGS are the arguments of said operator.
 328 Return a string representing an S-expression of the operator applied to its
 329 arguments."
 330   (if (= (length args) 1)
 331       (first args)
 332       (string-append "(" bi-op
 333                      (fold (lambda (arg seed) (string-append seed " " arg))
 334                            "" args) ")")))
 335
 336 (define (not->sexp-like arg)
 337   "If the string ARG is prefixed by a Cabal negation operator, convert it to
 338 an equivalent Scheme S-expression string."
 339   (if (regexp-exec not-rx arg)
 340       (string-append "(not "
 341                      (substring arg 1 (string-length arg))
 342                      ")")
 343       arg))
 344
 345 (define (parens-less-cond->sexp-like conditional)
 346   "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme
 347 syntax.  This procedure accepts only simple conditionals without parentheses."
 348   ;; The outher operation is the one with the lowest priority: OR
 349   (bi-op->sexp-like
 350    "or"
 351    ;; each OR argument may be an AND operation
 352    (map (lambda (or-arg)
 353           (let ((m-lst (list-matches and-rx or-arg)))
 354             ;; is there an AND operation?
 355             (if (> (length m-lst) 0)
 356                 (bi-op->sexp-like
 357                  "and"
 358                  ;; expand NOT operators when there are ANDs
 359                  (map not->sexp-like (bi-op-args or-arg m-lst)))
 360                 ;; ... and when there aren't.
 361                 (not->sexp-like or-arg))))
 362         ;; list of OR arguments
 363         (bi-op-args conditional (list-matches or-rx conditional)))))
 364
 365 (define test-keyword-ornament "__")
 366
 367 (define (conditional->sexp-like conditional)
 368   "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme
 369 syntax."
 370   ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests
 371   ;; keywords so that parentheses are only used to set precedences. This
 372   ;; substantially simplify parsing.
 373   (let ((conditional
 374          (regexp-substitute/global #f tests-rx conditional
 375                                    'pre 1 test-keyword-ornament 2
 376                                    test-keyword-ornament 'post)))
 377     (let loop ((sub-cond conditional))
 378       (let ((rx-result (regexp-exec parens-rx sub-cond)))
 379         (cond
 380          (rx-result
 381           (parens-less-cond->sexp-like
 382            (string-append
 383             (match:prefix rx-result)
 384             (loop (match:substring rx-result 1))
 385             (match:suffix rx-result))))
 386          (else
 387           (parens-less-cond->sexp-like sub-cond)))))))
 388
 389 (define (eval-flags sexp-like-cond flags)
 390   "SEXP-LIKE-COND is a string representing an S-expression conditional.  FLAGS
 391 is a list of flag name and value pairs as produced by 'get-flags'.  Substitute
 392 \"#t\" or \"#f\" according to the value of flags. (Default to \"True\")."
 393   (fold-right
 394    (lambda (flag sexp)
 395      (match flag
 396        ((name . value)
 397         (let ((rx (make-regexp
 398                    (string-append "flag" test-keyword-ornament name
 399                                   test-keyword-ornament))))
 400           (regexp-substitute/global
 401            #f rx sexp
 402            'pre (if (string-ci= value "False") "#f" "#t") 'post)))
 403        (_ sexp)))
 404    sexp-like-cond
 405    (cons '("[a-zA-Z0-9_-]+" . "True") flags)))
 406
 407 (define (eval-tests->sexp sexp-like-cond)
 408   "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and
 409 \"arch(...)\" with equivalent Scheme checks.  Retrun an S-expression."
 410   (with-input-from-string
 411       (fold-right
 412        (lambda (test sexp)
 413          (match test
 414            ((type pre-match post-match)
 415             (let ((rx (make-regexp
 416                        (string-append type test-keyword-ornament "(\\w+)"
 417                                       test-keyword-ornament))))
 418               (regexp-substitute/global
 419                #f rx sexp
 420                'pre pre-match 2 post-match 'post)))
 421            (_ sexp)))
 422        sexp-like-cond
 423        ;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux".
 424        '(("(os|arch)" "(string-match \"" "\" (%current-system))")))
 425     read))
 426
 427 (define (eval-impl sexp-like-cond)
 428   "Check for the Cabal test \"impl(...)\" in the string SEXP-LIKE-COND.
 429 Assume the module declaring the generated package includes a local variable
 430 called \"haskell-implementation\" with a string value of the form NAME-VERSION
 431 against which we compare."
 432   (with-output-to-string
 433     (lambda ()
 434       (write
 435        (with-input-from-string
 436            (fold-right
 437             (lambda (test sexp)
 438               (match test
 439                 ((pre-match post-match)
 440                  (let ((rx-with-version
 441                         (make-regexp
 442                          (string-append
 443                           "impl" test-keyword-ornament
 444                           "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *"
 445                           test-keyword-ornament)))
 446                        (rx-without-version
 447                         (make-regexp
 448                          (string-append "impl" test-keyword-ornament "(\\w+)"
 449                                         test-keyword-ornament))))
 450                    (if (regexp-exec rx-with-version sexp)
 451                        (regexp-substitute/global
 452                         #f rx-with-version sexp
 453                         'pre pre-match 2 " " post-match " \"" 1 "-" 3 "\")" 'post)
 454                        (regexp-substitute/global
 455                         #f rx-without-version sexp
 456                         'pre pre-match "-match \"" 1 "\" " post-match ")" 'post))))
 457                 (_ sexp)))
 458             sexp-like-cond
 459             '(("(string" "haskell-implementation")))
 460          read)))))
 461
 462 (define (eval-cabal-keywords sexp-like-cond flags)
 463   ((compose eval-tests->sexp eval-impl (cut eval-flags <> flags))
 464    sexp-like-cond))
 465
 466 (define (key->values meta key)
 467   "META is the representation of a Cabal file as produced by 'read-cabal'.
 468 Return the list of values associated with a specific KEY (a string)."
 469   (match meta
 470     (() '())
 471     (((((? (lambda(x) (equal? x key)))) v) r ...)
 472      v)
 473     (((k v) r ...)
 474      (key->values (cdr meta) key))
 475     (_ "key Not fount")))
 476
 477 (define (key-start-end->entries meta key-start-rx key-end-rx)
 478   "META is the representation of a Cabal file as produced by 'read-cabal'.
 479 Return all entries whose keys list starts with KEY-START and ends with
 480 KEY-END."
 481   (let ((pred
 482          (lambda (x)
 483            (and (regexp-exec key-start-rx (first x))
 484                 (regexp-exec key-end-rx (last x))))))
 485            ;; (equal? (list key-start key-end) (list (first x) (last x))))))
 486     (match meta
 487       (() '())
 488       ((((? pred k) v) r ...)
 489        (cons `(,k ,v)
 490              (key-start-end->entries (cdr meta) key-start-rx key-end-rx)))
 491       (((k v) r ...)
 492        (key-start-end->entries (cdr meta) key-start-rx key-end-rx))
 493       (_ "key Not fount"))))
 494
 495 (define else-rx
 496   (make-regexp "^else$"))
 497
 498 (define (count-if-else rx-result-ls)
 499   (apply + (map (lambda (m) (if m 1 0)) rx-result-ls)))
 500
 501 (define (analyze-entry-cond entry)
 502   (let* ((keys (first entry))
 503          (vals (second entry))
 504          (rx-cond-result
 505           (map (cut regexp-exec condition-rx <>) keys))
 506          (rx-else-result
 507           (map (cut regexp-exec else-rx <>) keys))
 508          (cond-no (count-if-else rx-cond-result))
 509          (else-no (count-if-else rx-else-result))
 510          (cond-idx (list-index (lambda (rx) (if rx #t #f)) rx-cond-result))
 511          (else-idx (list-index (lambda (rx) (if rx #t #f)) rx-else-result))
 512          (key-cond
 513               (cond
 514                ((or (and cond-idx else-idx (< cond-idx else-idx))
 515                     (and cond-idx (not else-idx)))
 516                 (match:substring
 517                  (receive (head tail)
 518                      (split-at rx-cond-result cond-idx) (first tail))))
 519                ((or (and cond-idx else-idx (> cond-idx else-idx))
 520                     (and (not cond-idx) else-idx))
 521                 (match:substring
 522                  (receive (head tail)
 523                      (split-at rx-else-result else-idx) (first tail))))
 524                (else
 525                 ""))))
 526     (values keys vals rx-cond-result
 527             rx-else-result cond-no else-no key-cond)))
 528
 529 (define (remove-cond entry cond)
 530   (match entry
 531     ((k v)
 532      (list (cdr (member cond k)) v))))
 533
 534 (define (group-and-reduce-level entries group group-cond)
 535   (let loop
 536       ((true-group group)
 537        (false-group '())
 538        (entries entries))
 539     (if (null? entries)
 540         (values (reverse true-group) (reverse false-group) entries)
 541         (let*-values (((entry) (first entries))
 542                       ((keys vals rx-cond-result rx-else-result
 543                              cond-no else-no key-cond)
 544                        (analyze-entry-cond entry)))
 545           (cond
 546            ((and (>= (+ cond-no else-no) 1) (string= group-cond key-cond))
 547             (loop (cons (remove-cond entry group-cond) true-group) false-group
 548                   (cdr entries)))
 549            ((and (>= (+ cond-no else-no) 1) (string= key-cond "else"))
 550             (loop true-group (cons (remove-cond entry "else") false-group)
 551                   (cdr entries)))
 552            (else
 553             (values (reverse true-group) (reverse false-group) entries)))))))
 554
 555 (define dependencies-rx
 556   (make-regexp "([a-zA-Z0-9_-]+) *[^,]*,?"))
 557
 558 (define (hackage-name->package-name name)
 559   (if (string-prefix? package-name-prefix name)
 560       (string-downcase name)
 561       (string-append package-name-prefix (string-downcase name))))
 562
 563 (define (split-and-filter-dependencies ls names-to-filter)
 564   "Split the comma separated list of dependencies LS coming from the Cabal
 565 file, filter packages included in NAMES-TO-FILTER and return a list with
 566 inputs suitable for the Guix package.  Currently the version information is
 567 discarded."
 568   (define (split-at-comma-and-filter d)
 569     (fold
 570      (lambda (m seed)
 571        (let* ((name (string-downcase (match:substring m 1)))
 572               (pkg-name (hackage-name->package-name name)))
 573          (if (member name names-to-filter)
 574              seed
 575              (cons (list pkg-name (list 'unquote (string->symbol pkg-name)))
 576                    seed))))
 577      '()
 578      (list-matches dependencies-rx d)))
 579
 580   (fold (lambda (d p) (append (split-at-comma-and-filter d) p)) '()  ls))
 581
 582 (define* (dependencies-cond->sexp meta #:key (include-test-dependencies? #t))
 583   "META is the representation of a Cabal file as produced by 'read-cabal'.
 584 Return an S-expression containing the list of dependencies as expected by the
 585 'inputs' field of a package.  The generated S-expressions may include
 586 conditionals as defined in the cabal file.  During this process we discard the
 587 version information of the packages."
 588   (define (take-dependencies meta)
 589     (let ((key-start-exe (make-regexp "executable"))
 590           (key-start-lib (make-regexp "library"))
 591           (key-start-tests (make-regexp "test-suite"))
 592           (key-end (make-regexp "build-depends")))
 593       (append
 594        (key-start-end->entries meta key-start-exe key-end)
 595        (key-start-end->entries meta key-start-lib key-end)
 596        (if include-test-dependencies?
 597            (key-start-end->entries meta key-start-tests key-end)
 598            '()))))
 599
 600   (let ((flags (get-flags (pre-process-entries-keys meta)))
 601         (augmented-ghc-std-libs (append (key->values meta "name")
 602                                         ghc-standard-libraries)))
 603     (delete-duplicates
 604      (let loop ((entries (take-dependencies meta))
 605                 (result '()))
 606        (if (null? entries)
 607            (reverse result)
 608            (let*-values (((entry) (first entries))
 609                          ((keys vals rx-cond-result rx-else-result
 610                                 cond-no else-no key-cond)
 611                           (analyze-entry-cond entry)))
 612              (cond
 613               ((= (+ cond-no else-no) 0)
 614                (loop (cdr entries)
 615                      (append
 616                       (split-and-filter-dependencies vals
 617                                                      augmented-ghc-std-libs)
 618                       result)))
 619               (else
 620                (let-values (((true-group false-group entries)
 621                              (group-and-reduce-level entries '()
 622                                                      key-cond))
 623                             ((cond-final) (eval-cabal-keywords
 624                                            (conditional->sexp-like
 625                                             (last (split-section key-cond)))
 626                                            flags)))
 627                  (loop entries
 628                        (cond
 629                         ((or (eq? cond-final #t) (equal? cond-final '(not #f)))
 630                          (append (loop true-group '()) result))
 631                         ((or (eq? cond-final #f) (equal? cond-final '(not #t)))
 632                          (append (loop false-group '()) result))
 633                         (else
 634                          (let ((true-group-result (loop true-group '()))
 635                                (false-group-result (loop false-group '())))
 636                            (cond
 637                             ((and (null? true-group-result)
 638                                   (null? false-group-result))
 639                              result)
 640                             ((null? false-group-result)
 641                              (cons `(unquote-splicing
 642                                      (when ,cond-final ,true-group-result))
 643                                    result))
 644                             ((null? true-group-result)
 645                              (cons `(unquote-splicing
 646                                      (unless ,cond-final ,false-group-result))
 647                                    result))
 648                             (else
 649                              (cons `(unquote-splicing
 650                                      (if ,cond-final
 651                                          ,true-group-result
 652                                          ,false-group-result))
 653                                    result))))))))))))))))
 654
 655 ;; Part 3:
 656 ;;
 657 ;; Retrive the desired package and its Cabal file from
 658 ;; http://hackage.haskell.org and construct the Guix package S-expression.
 659
 660 (define (hackage-fetch name-version)
 661   "Return the Cabal file for the package NAME-VERSION, or #f on failure.  If
 662 the version part is omitted from the package name, then return the latest
 663 version."
 664   (let*-values (((name version) (package-name->name+version name-version))
 665                 ((url)
 666                  (if version
 667                      (string-append "http://hackage.haskell.org/package/"
 668                                     name "-" version "/" name ".cabal")
 669                      (string-append "http://hackage.haskell.org/package/"
 670                                     name "/" name ".cabal"))))
 671     (call-with-temporary-output-file
 672      (lambda (temp port)
 673        (and (url-fetch url temp)
 674             (call-with-input-file temp read-cabal))))))
 675
 676 (define string->license
 677   ;; List of valid values from
 678   ;; https://www.haskell.org
 679   ;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html.
 680   (match-lambda
 681    ("GPL-2" 'gpl2)
 682    ("GPL-3" 'gpl3)
 683    ("GPL" "'gpl??")
 684    ("AGPL-3" 'agpl3)
 685    ("AGPL" "'agpl??")
 686    ("LGPL-2.1" 'lgpl2.1)
 687    ("LGPL-3" 'lgpl3)
 688    ("LGPL" "'lgpl??")
 689    ("BSD2" 'bsd-2)
 690    ("BSD3" 'bsd-3)
 691    ("MIT" 'expat)
 692    ("ISC" 'isc)
 693    ("MPL" 'mpl2.0)
 694    ("Apache-2.0" 'asl2.0)
 695    ((x) (string->license x))
 696    ((lst ...) `(list ,@(map string->license lst)))
 697    (_ #f)))
 698
 699 (define* (hackage-module->sexp meta #:key (include-test-dependencies? #t))
 700   "Return the `package' S-expression for a Cabal package.  META is the
 701 representation of a Cabal file as produced by 'read-cabal'."
 702
 703   (define name
 704     (first (key->values meta "name")))
 705
 706   (define version
 707     (first (key->values meta "version")))
 708
 709   (define description
 710     (let*-values (((description) (key->values meta "description"))
 711                   ((lines last)
 712                    (split-at description (- (length description) 1))))
 713       (fold-right (lambda (line seed) (string-append line "\n" seed))
 714                   (first last) lines)))
 715
 716   (define source-url
 717     (string-append "http://hackage.haskell.org/package/" name
 718                    "/" name "-" version ".tar.gz"))
 719
 720   ;; Several packages do not have an official home-page other than on Hackage.
 721   (define home-page
 722     (let ((home-page-entry (key->values meta "homepage")))
 723       (if (null? home-page-entry)
 724           (string-append "http://hackage.haskell.org/package/" name)
 725           (first home-page-entry))))
 726
 727   (define (maybe-inputs input-type inputs)
 728     (match inputs
 729       (()
 730        '())
 731       ((inputs ...)
 732        (list (list input-type
 733                    (list 'quasiquote inputs))))))
 734
 735   (let ((tarball (with-store store
 736                    (download-to-store store source-url))))
 737     `(package
 738        (name ,(hackage-name->package-name name))
 739        (version ,version)
 740        (source (origin
 741                  (method url-fetch)
 742                  (uri (string-append ,@(factorize-uri source-url version)))
 743                  (sha256
 744                   (base32
 745                    ,(if tarball
 746                         (bytevector->nix-base32-string (file-sha256 tarball))
 747                         "failed to download tar archive")))))
 748        (build-system haskell-build-system)
 749        ,@(maybe-inputs 'inputs
 750                        (dependencies-cond->sexp meta
 751                                                 #:include-test-dependencies?
 752                                                 include-test-dependencies?))
 753        (home-page ,home-page)
 754        (synopsis ,@(key->values meta "synopsis"))
 755        (description ,description)
 756        (license ,(string->license (key->values meta "license"))))))
 757
 758 (define* (hackage->guix-package module-name
 759                                 #:key (include-test-dependencies? #t))
 760   "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, and return
 761 the `package' S-expression corresponding to that package, or #f on failure."
 762   (let ((module-meta (hackage-fetch module-name)))
 763     (and=> module-meta (cut hackage-module->sexp <>
 764                             #:include-test-dependencies?
 765                             include-test-dependencies?))))
 766
 767 ;;; cabal.scm ends here