code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 cabal)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (system base lalr)
  #:use-module (rnrs enums)
  #:use-module (guix utils)
  #:export (read-cabal
            eval-cabal

            cabal-custom-setup-dependencies

            cabal-package?
            cabal-package-name
            cabal-package-version
            cabal-package-revision
            cabal-package-license
            cabal-package-home-page
            cabal-package-source-repository
            cabal-package-synopsis
            cabal-package-description
            cabal-package-executables
            cabal-package-library
            cabal-package-test-suites
            cabal-package-flags
            cabal-package-eval-environment
            cabal-package-custom-setup

            cabal-source-repository?
            cabal-source-repository-use-case
            cabal-source-repository-type
            cabal-source-repository-location

            cabal-flag?
            cabal-flag-name
            cabal-flag-description
            cabal-flag-default
            cabal-flag-manual

            cabal-dependency?
            cabal-dependency-name
            cabal-dependency-version

            cabal-executable?
            cabal-executable-name
            cabal-executable-dependencies

            cabal-library?
            cabal-library-dependencies

            cabal-test-suite?
            cabal-test-suite-name
            cabal-test-suite-dependencies))

;; Part 1:
;;
;; Functions used to read a Cabal file.

;; Comment:
;;
;; The use of virtual closing braces VCCURLY and some lexer functions were
;; inspired from http://hackage.haskell.org/package/haskell-src

;; Object containing information about the structure of a block: (i) delimited
;; by braces or by indentation, (ii) minimum indentation.
(define-record-type  <parse-context>
  (make-parse-context mode indentation)
  parse-context?
  (mode parse-context-mode)                ; 'layout or 'no-layout
  (indentation parse-context-indentation)) ; #f for 'no-layout

;; <parse-context> mode set universe
(define-enumeration context (layout no-layout) make-context)

(define (make-stack)
  "Creates a simple stack closure.  Actions on the generated stack are
requested by calling it with one of the following symbols as the first
argument: 'empty?, 'push!, 'top, 'pop! and 'clear!.  The action 'push! is the
only one requiring a second argument corresponding to the object to be added
to the stack."
  (let ((stack '()))
    (lambda (msg . args)
      (cond ((eqv? msg 'empty?) (null? stack))
            ((eqv? msg 'push!) (set! stack (cons (first args) stack)))
            ((eqv? msg 'top) (if (null? stack) '() (first stack)))
            ((eqv? msg 'pop!) (match stack
                                ((e r ...) (set! stack (cdr stack)) e)
                                (_ #f)))
            ((eqv? msg 'clear!) (set! stack '()))
            (else #f)))))

;; Stack to track the structure of nested blocks and simple interface
(define context-stack (make-parameter (make-stack)))

(define (context-stack-empty?) ((context-stack) 'empty?))

(define (context-stack-push! e) ((context-stack) 'push! e))

(define (context-stack-top) ((context-stack) 'top))

(define (context-stack-pop!) ((context-stack) 'pop!))

(define (context-stack-clear!) ((context-stack) 'clear!))

;; Indentation of the line being parsed.
(define current-indentation (make-parameter 0))

;; Signal to reprocess the beginning of line, in case we need to close more
;; than one indentation level.
(define check-bol? (make-parameter #f))

;; Name of the file being parsed. Used in error messages.
(define cabal-file-name (make-parameter "unknowk"))

;; Specify the grammar of a Cabal file and generate a suitable syntax analyser.
(define (make-cabal-parser)
  "Generate a parser for Cabal files."
  (lalr-parser
   ;; --- token definitions
   (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE -ANY -NONE
           (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB COMMON OCURLY)
           (left: OR)
           (left: PROPERTY AND)
           (right: ELSE NOT))
   ;; --- rules
   (body        (properties sections)   : (append $1 $2))
   (sections    (sections flags)        : (append $1 $2)
                (sections source-repo)  : (append $1 (list $2))
                (sections executables)  : (append $1 $2)
                (sections test-suites)  : (append $1 $2)
                (sections common)       : (append $1 $2)
                (sections custom-setup) : (append $1 $2)
                (sections benchmarks)   : (append $1 $2)
                (sections lib-sec)      : (append $1 (list $2))
                ()                      : '())
   (flags       (flags flag-sec)        : (append $1 (list $2))
                (flag-sec)              : (list $1))
   (flag-sec    (FLAG OCURLY properties CCURLY) : `(section flag ,$1 ,$3)
                (FLAG open properties close)    : `(section flag ,$1 ,$3)
                (FLAG)                          : `(section flag ,$1 '()))
   (source-repo (SOURCE-REPO OCURLY properties CCURLY)
                : `(section source-repository ,$1 ,$3)
                (SOURCE-REPO open properties close)
                : `(section source-repository ,$1 ,$3))
   (properties  (properties PROPERTY)   : (append $1 (list $2))
                (PROPERTY)              : (list $1))
   (executables (executables exec-sec)  : (append $1 (list $2))
                (exec-sec)              : (list $1))
   (exec-sec    (EXEC OCURLY exprs CCURLY) : `(section executable ,$1 ,$3)
                (EXEC open exprs close)    : `(section executable ,$1 ,$3))
   (test-suites (test-suites ts-sec)    : (append $1 (list $2))
                (ts-sec)                : (list $1))
   (ts-sec      (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3)
                (TEST-SUITE open exprs close)    : `(section test-suite ,$1 ,$3))
   (common      (common common-sec)     : (append $1 (list $2))
                (common-sec)            : (list $1))
   (common-sec  (COMMON OCURLY exprs CCURLY)     : `(section common ,$1 ,$3)
                (COMMON open exprs close)        : `(section common ,$1 ,$3))
   (custom-setup (CUSTOM-SETUP exprs) : (list `(section custom-setup ,$1 ,$2)))
   (benchmarks  (benchmarks bm-sec)     : (append $1 (list $2))
                (bm-sec)                : (list $1))
   (bm-sec      (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3)
                (BENCHMARK open exprs close)    : `(section benchmark ,$1 ,$3))
   (lib-sec     (LIB OCURLY exprs CCURLY) : `(section library ,$3)
                (LIB open exprs close)    : `(section library ,$3))
   (exprs       (exprs PROPERTY)         : (append $1 (list $2))
                (PROPERTY)               : (list $1)
                (exprs if-then-else)     : (append $1 (list $2))
                (if-then-else)           : (list $1)
                (exprs if-then)          : (append $1 (list $2))
                (if-then)                : (list $1))
   (if-then-else (IF tests OCURLY exprs CCURLY ELSE OCURLY exprs CCURLY)
                 : `(if ,$2 ,$4 ,$8)
                 (IF tests open exprs close ELSE OCURLY exprs CCURLY)
                 : `(if ,$2 ,$4 ,$8)
                 ;; The 'open' token after 'tests' is shifted after an 'exprs'
                 ;; is found.  This is because, instead of 'exprs' a 'OCURLY'
                 ;; token is a valid alternative.  For this reason, 'open'
                 ;; pushes a <parse-context> with a line indentation equal to
                 ;; the indentation of 'exprs'.
                 ;;
                 ;; Differently from this, without the rule above this
                 ;; comment, when an 'ELSE' token is found, the 'open' token
                 ;; following the 'ELSE' would be shifted immediately, before
                 ;; the 'exprs' is found (because there are no other valid
                 ;; tokens).  The 'open' would therefore create a
                 ;; <parse-context> with the indentation of 'ELSE' and not
                 ;; 'exprs', creating an inconsistency.  We therefore allow
                 ;; mixed style conditionals.
                 (IF tests open exprs close ELSE open exprs close)
                 : `(if ,$2 ,$4 ,$8))
   (if-then     (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ())
                (IF tests open exprs close)    : `(if ,$2 ,$4 ()))
   (tests       (TEST OPAREN ID CPAREN)        : `(,$1 ,$3)
                (TRUE)                         : 'true
                (FALSE)                        : 'false
                (TEST OPAREN ID RELATION VERSION CPAREN)
                : `(,$1 ,(string-append $3 " " $4 " " $5))
                (TEST OPAREN ID -ANY CPAREN)
                : `(,$1 ,(string-append $3 " -any"))
                (TEST OPAREN ID -NONE CPAREN)
                : `(,$1 ,(string-append $3 " -none"))
                (TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN)
                : `(and (,$1 ,(string-append $3 " " $4 " " $5))
                        (,$1 ,(string-append $3 " " $7 " " $8)))
               (NOT tests)                     : `(not ,$2)
               (tests AND tests)               : `(and ,$1 ,$3)
               (tests OR tests)                : `(or ,$1 ,$3)
               (OPAREN tests CPAREN)           : $2)
   (open       () : (context-stack-push!
                                   (make-parse-context (context layout)
                                                       (current-indentation))))
   (close      (VCCURLY))))

(define (peek-next-line-indent port)
  "This function can be called when the next character on PORT is #\newline
and returns the indentation of the line starting after the #\newline
character.  Discard (and consume) empty and comment lines."
  (if (eof-object? (peek-char port))
      ;; If the file is missing the #\newline on the last line, add it and act
      ;; as if it were there. This is needed for proper operation of
      ;; indentation based block recognition (based on ‘port-column’).
      (begin (unread-char #\newline port) (read-char port) 0)
      (let ((initial-newline (string (read-char port))))
        (let loop ((char (peek-char port))
                   (word ""))
          (cond ((eqv? char #\newline) (read-char port)
                 (loop (peek-char port) ""))
                ((or (eqv? char #\space) (eqv? char #\tab))
                 (let ((c (read-char port)))
                   (loop (peek-char port) (string-append word (string c)))))
                ((comment-line port char) (loop (peek-char port) ""))
                (else
                 (let ((len (string-length word)))
                   (unread-string (string-append initial-newline word) port)
                   len)))))))

(define* (read-value port value min-indent #:optional (separator " "))
  "The next character on PORT must be #\newline.  Append to VALUE the
following lines with indentation larger than MIN-INDENT."
  (let loop ((val (string-trim-both value))
             (x (peek-next-line-indent port)))
    (if (> x min-indent)
        (begin
          (read-char port) ; consume #\newline
          (loop (string-append
                 val (if (string-null? val) "" separator)
                 (string-trim-both (read-delimited "\n" port 'peek)))
                (peek-next-line-indent port)))
        val)))

(define* (read-braced-value port)
  "Read up to a closing brace."
  (string-trim-both (read-delimited "}" port 'trim)))

(define (lex-white-space port bol)
  "Consume white spaces and comment lines on PORT.  If a new line is started return #t,
otherwise return BOL (beginning-of-line)."
  (let loop ((c (peek-char port))
             (bol bol))
    (cond
     ((and (not (eof-object? c))
           (or (char=? c #\space) (char=? c #\tab)))
      (read-char port)
      (loop (peek-char port) bol))
     ((and (not (eof-object? c)) (char=? c #\newline))
      (read-char port)
      (loop (peek-char port) #t))
     ((comment-line port c)
      (lex-white-space port bol))
     (else
      bol))))

(define (lex-bol port)
  "Process the beginning of a line on PORT: update current-indentation and
check the end of an indentation based context."
  (let ((loc (make-source-location (cabal-file-name) (port-line port)
                                   (port-column port) -1 -1)))
    (current-indentation (source-location-column loc))
    (case (get-offside port)
      ((less-than)
       (check-bol? #t) ; need to check if closing more than 1 indent level.
       (unless (context-stack-empty?) (context-stack-pop!))
       (make-lexical-token 'VCCURLY loc #f))
      (else
       (lex-token port)))))

(define (bol? port) (or (check-bol?) (= (port-column port) 0)))

(define (comment-line port c)
  "If PORT starts with a comment line, consume it up to, but not including
#\newline.  C is the next character on PORT."
  (cond ((and (not (eof-object? c)) (char=? c #\-))
         (read-char port)
         (let ((c2 (peek-char port)))
           (if (char=? c2 #\-)
               (read-delimited "\n" port 'peek)
               (begin (unread-char c port) #f))))
        (else #f)))

(define-enumeration ordering (less-than equal greater-than) make-ordering)

(define (get-offside port)
  "In an indentation based context return the symbol 'greater-than, 'equal or
'less-than to signal if the current column number on PORT is greater-, equal-,
or less-than the indentation of the current context."
  (let ((x (port-column port)))
    (match (context-stack-top)
      (($ <parse-context> 'layout indentation)
       (cond
        ((> x indentation) (ordering greater-than))
        ((= x indentation) (ordering equal))
        (else (ordering less-than))))
      (_ (ordering greater-than)))))

;; (Semi-)Predicates for individual tokens.

(define (is-relation? c)
  (and (char? c) (any (cut char=? c <>) '(#\< #\> #\=))))

(define* (make-rx-matcher pat #:optional (flag #f))
  "Compile PAT into a regular expression with FLAG and creates a function
matching a string against the created regexp."
  (let ((rx (if flag
                (make-regexp pat flag)
                (make-regexp pat))))
    (cut regexp-exec rx <>)))

(define is-layout-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?[^{}]*)$"
                                            regexp/icase))

(define is-braced-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*\\{[ \t]*$"
                                            regexp/icase))

(define is-flag (make-rx-matcher "^flag +([a-z0-9_-]+)"
                                 regexp/icase))

(define is-src-repo
  (make-rx-matcher "^source-repository +([a-z0-9_-]+)"
                   regexp/icase))

(define is-exec (make-rx-matcher "^executable +([a-z0-9_-]+)"
                                 regexp/icase))

(define is-test-suite (make-rx-matcher "^test-suite +([a-z0-9_-]+)"
                                       regexp/icase))

(define is-common (make-rx-matcher "^common +([a-z0-9_-]+)"
                                   regexp/icase))

(define is-custom-setup (make-rx-matcher "^(custom-setup)"
                                         regexp/icase))

(define is-benchmark (make-rx-matcher "^benchmark +([a-z0-9_-]+)"
                                      regexp/icase))

(define is-lib (make-rx-matcher "^library *" regexp/icase))

(define is-else (make-rx-matcher "^else" regexp/icase))

(define (is-if s) (string-ci=? s "if"))

(define (is-true s) (string-ci=? s "true"))

(define (is-false s) (string-ci=? s "false"))

(define (is-any s) (string-ci=? s "-any"))

(define (is-none s) (string-ci=? s "-none"))

(define (is-and s) (string=? s "&&"))

(define (is-or s) (string=? s "||"))

(define (is-id s port)
  (let ((cabal-reserved-words
         '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup"
           "source-repository" "benchmark" "common"))
        (spaces (read-while (cut char-set-contains? char-set:blank <>) port))
        (c (peek-char port)))
    (unread-string spaces port)
    (and (every (cut string-ci<> s <>) cabal-reserved-words)
         (and (not (char=? (last (string->list s)) #\:))
              (not (char=? #\: c))))))

(define (is-test s port)
  (let ((tests-rx (make-regexp "os|arch|flag|impl"))
        (spaces (read-while (cut char-set-contains? char-set:blank <>) port))
        (c (peek-char port)))
    (if (and (regexp-exec tests-rx s) (char=? #\( c))
        #t
        (begin (unread-string spaces port) #f))))

;; Lexers for individual tokens.

(define (lex-relation loc port)
  (make-lexical-token 'RELATION loc (read-while is-relation? port)))

(define (lex-version loc port)
  (make-lexical-token 'VERSION loc
                      (read-while (lambda (x)
                                    (or (char-numeric? x)
                                        (char=? x #\*)
                                        (char=? x #\.)))
                                  port)))

(define* (read-while is? port #:optional
                     (is-if-followed-by? (lambda (c) #f))
                     (is-allowed-follower? (lambda (c) #f)))
  "Read from PORT as long as: (i) either the read character satisfies the
predicate IS?, or (ii) it satisfies the predicate IS-IF-FOLLOWED-BY? and the
character immediately following it satisfies IS-ALLOWED-FOLLOWER?.  Returns a
string with the read characters."
  (let loop ((c (peek-char port))
             (res '()))
    (cond ((and (not (eof-object? c)) (is? c))
           (let ((c (read-char port)))
             (loop (peek-char port) (append res (list c)))))
          ((and (not (eof-object? c)) (is-if-followed-by? c))
           (let ((c (read-char port))
                 (c2 (peek-char port)))
             (if (and (not (eof-object? c2)) (is-allowed-follower? c2))
                 (loop c2 (append res (list c)))
                 (begin (unread-char c) (list->string res)))))
          (else (list->string res)))))

(define (lex-layout-property k-v-rx-res loc port)
  (let ((key (string-downcase (match:substring k-v-rx-res 1)))
        (value (match:substring k-v-rx-res 2)))
    (make-lexical-token
     'PROPERTY loc
     (list key `(,(read-value port value (current-indentation)))))))

(define (lex-braced-property k-rx-res loc port)
  (let ((key (string-downcase (match:substring k-rx-res 1))))
    (make-lexical-token
     'PROPERTY loc
     (list key `(,(read-braced-value port))))))

(define (lex-rx-res rx-res token loc)
  (let ((name (string-downcase (match:substring rx-res 1))))
    (make-lexical-token token loc name)))

(define (lex-flag flag-rx-res loc) (lex-rx-res flag-rx-res 'FLAG loc))

(define (lex-src-repo src-repo-rx-res loc)
  (lex-rx-res src-repo-rx-res 'SOURCE-REPO loc))

(define (lex-exec exec-rx-res loc) (lex-rx-res exec-rx-res 'EXEC loc))

(define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc))

(define (lex-common common-rx-res loc) (lex-rx-res common-rx-res 'COMMON loc))

(define (lex-custom-setup ts-rx-res loc) (lex-rx-res ts-rx-res 'CUSTOM-SETUP loc))

(define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc))

(define (lex-lib loc) (make-lexical-token 'LIB loc #f))

(define (lex-else loc) (make-lexical-token 'ELSE loc #f))

(define (lex-if loc) (make-lexical-token 'IF loc #f))

(define (lex-true loc) (make-lexical-token 'TRUE loc #t))

(define (lex-false loc) (make-lexical-token 'FALSE loc #f))

(define (lex-any loc) (make-lexical-token '-ANY loc #f))

(define (lex-none loc) (make-lexical-token '-NONE loc #f))

(define (lex-and loc) (make-lexical-token 'AND loc #f))

(define (lex-or loc) (make-lexical-token 'OR loc #f))

(define (lex-id w loc) (make-lexical-token 'ID loc w))

(define (lex-test w loc) (make-lexical-token 'TEST loc (string->symbol w)))

;; Lexer for tokens recognizable by single char.

(define* (is-ref-char->token ref-char next-char token loc port
                         #:optional (hook-fn #f))
  "If the next character NEXT-CHAR on PORT is REF-CHAR, then read it,
execute HOOK-FN if it isn't #f and return a lexical token of type TOKEN with
location information LOC."
  (cond ((char=? next-char ref-char)
         (read-char port)
         (when hook-fn (hook-fn))
         (make-lexical-token token loc (string next-char)))
        (else #f)))

(define (is-ocurly->token c loc port)
  (is-ref-char->token #\{ c 'OCURLY loc port
                  (lambda ()
                    (context-stack-push! (make-parse-context
                                          (context no-layout) #f)))))

(define (is-ccurly->token c loc port)
  (is-ref-char->token #\} c 'CCURLY loc port (lambda () (context-stack-pop!))))

(define (is-oparen->token c loc port)
  (is-ref-char->token #\( c 'OPAREN loc port))

(define (is-cparen->token c loc port)
  (is-ref-char->token #\) c 'CPAREN loc port))

(define (is-not->token c loc port)
  (is-ref-char->token #\! c 'NOT loc port))

(define (is-version? c) (char-numeric? c))

;; Main lexer functions

(define (lex-single-char port loc)
  "Process tokens which can be recognised by peeking the next character on
PORT.  If no token can be recognized return #f.  LOC is the current port
location."
  (let* ((c (peek-char port)))
    (cond ((eof-object? c) (read-char port) '*eoi*)
          ((is-ocurly->token c loc port))
          ((is-ccurly->token c loc port))
          ((is-oparen->token c loc port))
          ((is-cparen->token c loc port))
          ((is-not->token c loc port))
          ((is-version? c) (lex-version loc port))
          ((is-relation? c) (lex-relation loc port))
          (else
           #f))))

(define (lex-word port loc)
  "Process tokens which can be recognized by reading the next word form PORT.
LOC is the current port location."
  (let* ((w (read-delimited " <>=()\t\n" port 'peek)))
    (cond ((is-if w) (lex-if loc))
          ((is-test w port) (lex-test w loc))
          ((is-true w) (lex-true loc))
          ((is-false w) (lex-false loc))
          ((is-any w) (lex-any loc))
          ((is-none w) (lex-none loc))
          ((is-and w) (lex-and loc))
          ((is-or w) (lex-or loc))
          ((is-id w port) (lex-id w loc))
          (else (unread-string w port) #f))))

(define (lex-line port loc)
  "Process tokens which can be recognised by reading a line from PORT.  LOC is
the current port location."
  (let* ((s (read-delimited "\n{}" port 'peek)))
    (cond
     ((is-flag s) => (cut lex-flag <> loc))
     ((is-src-repo s) => (cut lex-src-repo <> loc))
     ((is-exec s) => (cut lex-exec <> loc))
     ((is-test-suite s) => (cut lex-test-suite <> loc))
     ((is-common s) => (cut lex-common <> loc))
     ((is-custom-setup s) => (cut lex-custom-setup <> loc))
     ((is-benchmark s) => (cut lex-benchmark <> loc))
     ((is-lib s) (lex-lib loc))
     ((is-else s) (lex-else loc))
     (else (unread-string s port) #f))))

(define (lex-property port loc)
  (let* ((s (read-delimited "\n" port 'peek)))
    (cond
      ((is-braced-property s) => (cut lex-braced-property <> loc port))
      ((is-layout-property s) => (cut lex-layout-property <> loc port))
      (else #f))))

(define (lex-token port)
  (let* ((loc (make-source-location (cabal-file-name) (port-line port)
                                    (port-column port) -1 -1)))
    (or (lex-single-char port loc)
        (lex-word port loc)
        (lex-line port loc)
        (lex-property port loc))))

;; Lexer- and error-function generators

(define (errorp)
  "Generates the lexer error function."
  (let ((p (current-error-port)))
    (lambda (message . args)
      (format p "~a" message)
      (if (and (pair? args) (lexical-token? (car args)))
          (let* ((token (car args))
                 (source (lexical-token-source token))
                 (line (source-location-line source))
                 (column (source-location-column source)))
            (format p "~a " (or (lexical-token-value token)
                                 (lexical-token-category token)))
            (when (and (number? line) (number? column))
              (format p "(at line ~a, column ~a)" (1+ line) column)))
          (for-each display args))
      (format p "~%"))))

(define (make-lexer port)
  "Generate the Cabal lexical analyser reading from PORT."
  (let ((p port))
    (lambda ()
      (let ((bol (lex-white-space p (bol? p))))
        (check-bol? #f)
        (if bol (lex-bol p) (lex-token p))))))

(define* (read-cabal #:optional (port (current-input-port))
                     (file-name #f))
  "Read a Cabal file from PORT.  FILE-NAME is a string used in error messages.
If #f use the function 'port-filename' to obtain it."
  (let ((cabal-parser (make-cabal-parser)))
    (parameterize ((cabal-file-name
                    (or file-name (port-filename port) "standard input"))
                   (current-indentation 0)
                   (check-bol? #f)
                   (context-stack (make-stack)))
      (cabal-parser (make-lexer port) (errorp)))))

;; Part 2:
;;
;; Evaluate the S-expression returned by 'read-cabal'.

;; This defines the object and interface that we provide to access the Cabal
;; file information.  Note that this does not include all the pieces of
;; information of the Cabal file, but only the ones we currently are
;; interested in.
(define-record-type <cabal-package>
  (make-cabal-package name version revision license home-page source-repository
                      synopsis description
                      executables lib test-suites
                      flags eval-environment custom-setup)
  cabal-package?
  (name   cabal-package-name)
  (version cabal-package-version)
  (revision cabal-package-revision)
  (license cabal-package-license)
  (home-page cabal-package-home-page)
  (source-repository cabal-package-source-repository)
  (synopsis cabal-package-synopsis)
  (description cabal-package-description)
  (executables cabal-package-executables)
  (lib cabal-package-library) ; 'library' is a Scheme keyword
  (test-suites cabal-package-test-suites)
  (flags cabal-package-flags)
  (eval-environment cabal-package-eval-environment) ; alist
  (custom-setup cabal-package-custom-setup))

(set-record-type-printer! <cabal-package>
                          (lambda (package port)
                            (format port "#<cabal-package ~a@~a>"
                                      (cabal-package-name package)
                                      (cabal-package-version package))))

(define-record-type <cabal-source-repository>
  (make-cabal-source-repository use-case type location)
  cabal-source-repository?
  (use-case cabal-source-repository-use-case)
  (type cabal-source-repository-type)
  (location cabal-source-repository-location))

;; We need to be able to distinguish the value of a flag from the Scheme #t
;; and #f values.
(define-record-type <cabal-flag>
  (make-cabal-flag name description default manual)
  cabal-flag?
  (name cabal-flag-name)
  (description cabal-flag-description)
  (default cabal-flag-default) ; 'true or 'false
  (manual cabal-flag-manual))  ; 'true or 'false

(set-record-type-printer! <cabal-flag>
                          (lambda (package port)
                            (format port "#<cabal-flag ~a default:~a>"
                                      (cabal-flag-name package)
                                      (cabal-flag-default package))))

(define-record-type <cabal-dependency>
  (make-cabal-dependency name version)
  cabal-dependency?
  (name cabal-dependency-name)
  (version cabal-dependency-version))

(define-record-type <cabal-executable>
  (make-cabal-executable name dependencies)
  cabal-executable?
  (name cabal-executable-name)
  (dependencies cabal-executable-dependencies)) ; list of <cabal-dependency>

(define-record-type <cabal-library>
  (make-cabal-library dependencies)
  cabal-library?
  (dependencies cabal-library-dependencies)) ; list of <cabal-dependency>

(define-record-type <cabal-test-suite>
  (make-cabal-test-suite name dependencies)
  cabal-test-suite?
  (name cabal-test-suite-name)
  (dependencies cabal-test-suite-dependencies)) ; list of <cabal-dependency>

(define-record-type <cabal-custom-setup>
  (make-cabal-custom-setup name dependencies)
  cabal-custom-setup?
  (name cabal-custom-setup-name)
  (dependencies cabal-custom-setup-dependencies)) ; list of <cabal-dependency>

(define (cabal-flags->alist flag-list)
    "Return an alist associating the flag name to its default value from a
list of <cabal-flag> objects."
  (map (lambda (flag) (cons (cabal-flag-name flag) (cabal-flag-default flag)))
       flag-list))

(define (eval-cabal cabal-sexp env)
  "Given the CABAL-SEXP produced by 'read-cabal', evaluate all conditionals
and return a 'cabal-package' object.  The values of all tests can be
overwritten by specifying the desired value in ENV.  ENV must be an alist.
The accepted keys are: \"os\", \"arch\", \"impl\" and a name of a flag.  The
value associated with a flag has to be either \"true\" or \"false\".  The
value associated with other keys has to conform to the Cabal file format
definition."
  (define (os name)
    (let ((env-os (or (assoc-ref env "os") "linux")))
      (string-match env-os name)))

  (define (arch name)
    (let ((env-arch (or (assoc-ref env "arch") "x86_64")))
      (string-match env-arch name)))

  (define (comp-name+version haskell)
    "Extract the compiler name and version from the string HASKELL."
    (let* ((matcher-fn (make-rx-matcher "([a-zA-Z0-9_]+)-([0-9.]+)"))
           (name (or (and=> (matcher-fn haskell) (cut match:substring <> 1))
                     haskell))
           (version (and=> (matcher-fn haskell) (cut match:substring <> 2))))
      (values name version)))

  (define (comp-spec-name+op+version spec)
    "Extract the compiler specification from SPEC.  Return the compiler name,
the ordering operation and the version."
    (let* ((with-ver-matcher-fn (make-rx-matcher
                                 "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *"))
           (without-ver-matcher-fn (make-rx-matcher "([a-zA-Z0-9_-]+)"))
           (without-ver-matcher-fn-2 (make-rx-matcher "([a-zA-Z0-9_-]+) (-any|-none)"))
           (name (or (and=> (with-ver-matcher-fn spec)
                            (cut match:substring <> 1))
                     (and=> (without-ver-matcher-fn-2 spec)
                            (cut match:substring <> 1))
                     (match:substring (without-ver-matcher-fn spec) 1)))
           (operator (or (and=> (with-ver-matcher-fn spec)
                                (cut match:substring <> 2))
                         (and=> (without-ver-matcher-fn-2 spec)
                                (cut match:substring <> 2))))
           (version (or (and=> (with-ver-matcher-fn spec)
                               (cut match:substring <> 3))
                        (and=> (without-ver-matcher-fn-2 spec)
                               (cut match:substring <> 2)))))
      (values name operator version)))

  (define (impl haskell)
    (let*-values (((comp-name comp-ver)
                   (comp-name+version (or (assoc-ref env "impl") "ghc")))
                  ((spec-name spec-op spec-ver)
                   (comp-spec-name+op+version haskell)))
      (if (and spec-ver comp-ver)
          (cond
           ((not (string= spec-name comp-name)) #f)
           ((string= spec-op "==") (string= spec-ver comp-ver))
           ((string= spec-op ">=") (version>=? comp-ver spec-ver))
           ((string= spec-op ">") (version>? comp-ver spec-ver))
           ((string= spec-op "<=") (not (version>? comp-ver spec-ver)))
           ((string= spec-op "<") (not (version>=? comp-ver spec-ver)))
           ((string= spec-op "-any") #t)
           ((string= spec-op "-none") #f)
           (else
            (raise (condition
                    (&message (message "Failed to evaluate 'impl' test."))))))
          (string-match spec-name comp-name))))

  (define (cabal-flags)
    (make-cabal-section cabal-sexp 'flag))

  (define (flag name)
    (let ((value (or (assoc-ref env name)
                     (assoc-ref (cabal-flags->alist (cabal-flags)) name))))
      (if (eq? value 'false) #f #t)))

  (define common-stanzas
    (filter-map (match-lambda
                  (('section 'common common-name common)
                   (cons common-name common))
                  (_ #f))
                cabal-sexp))

  (define (eval sexp)
    "Given an SEXP and an ENV, return the evaluated (SEXP . ENV)."
    (match sexp
      (() '())
      ;; nested 'if'
      ((('if predicate true-group false-group) rest ...)
       (append (if (eval predicate)
                   (eval true-group)
                   (eval false-group))
               (eval rest)))
      (('if predicate true-group false-group)
       (if (eval predicate)
           (eval true-group)
           (eval false-group)))
      (('flag name) (flag name))
      (('os name) (os name))
      (('arch name) (arch name))
      (('impl name) (impl name))
      ('true #t)
      ('false #f)
      (('not name) (not (eval name)))
      ;; 'and' and 'or' aren't functions, thus we can't use apply
      (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args)))
      (('or args ...) (fold (lambda (e s) (or e s)) #f (eval args)))
      ;; no need to evaluate flag parameters
      (('section 'flag name parameters)
       (list 'section 'flag name parameters))
      (('section 'custom-setup parameters)
       (list 'section 'custom-setup parameters))
      ;; library does not have a name parameter
      (('section 'library parameters)
       (list 'section 'library (eval parameters)))
      (('section type name parameters)
       (list 'section type name (eval parameters)))
      (((? string? name) values)
       (list name values))
      ((("import" imports) rest ...)
       (eval (append (append-map (cut assoc-ref common-stanzas <>) imports)
                     rest)))
      ((element rest ...)
       (cons (eval element) (eval rest)))
      (_ (raise (condition
                 (&message (message "Failed to evaluate Cabal file. \
See the manual for limitations.")))))))

  (define (cabal-evaluated-sexp->package evaluated-sexp)
    (let* ((name (lookup-join evaluated-sexp "name"))
           (version (lookup-join evaluated-sexp "version"))
           (revision (lookup-join evaluated-sexp "x-revision"))
           (license (lookup-join evaluated-sexp "license"))
           (home-page (lookup-join evaluated-sexp "homepage"))
           (home-page-or-hackage
            (if (string-null? home-page)
                (string-append "http://hackage.haskell.org/package/" name)
                home-page))
           (source-repository (make-cabal-section evaluated-sexp
                                                  'source-repository))
           (synopsis (lookup-join evaluated-sexp "synopsis"))
           (description (lookup-join evaluated-sexp "description"))
           (executables (make-cabal-section evaluated-sexp 'executable))
           (lib (make-cabal-section evaluated-sexp 'library))
           (test-suites (make-cabal-section evaluated-sexp 'test-suite))
           (flags (make-cabal-section evaluated-sexp 'flag))
           (eval-environment '())
           (custom-setup (match (make-cabal-section evaluated-sexp 'custom-setup)
                           ((x) x)
                           (_ #f))))
      (make-cabal-package name version revision license home-page-or-hackage
                          source-repository synopsis description executables lib
                          test-suites flags eval-environment custom-setup)))

  ((compose cabal-evaluated-sexp->package eval) cabal-sexp))

(define (make-cabal-section sexp section-type)
  "Given an SEXP as produced by 'read-cabal', produce a list of objects
pertaining to SECTION-TYPE sections.  SECTION-TYPE must be one of:
'executable, 'flag, 'test-suite, 'custom-setup, 'source-repository or
'library."
  (filter-map (cut match <>
                   (('section (? (cut equal? <> section-type)) name parameters)
                    (case section-type
                      ((test-suite) (make-cabal-test-suite
                                      name (dependencies parameters)))
                      ((custom-setup) (make-cabal-custom-setup
                                       name (dependencies parameters "setup-depends")))
                      ((executable) (make-cabal-executable
                                      name (dependencies parameters)))
                      ((source-repository) (make-cabal-source-repository
                                            name
                                            (lookup-join parameters "type")
                                            (lookup-join parameters "location")))
                      ((flag)
                       (let* ((default (lookup-join parameters "default"))
                              (default-true-or-false
                                (if (and default (string-ci=? "false" default))
                                    'false
                                    'true))
                              (description (lookup-join parameters "description"))
                              (manual (lookup-join parameters "manual"))
                              (manual-true-or-false
                               (if (and manual (string-ci=? "true" manual))
                                   'true
                                   'false)))
                         (make-cabal-flag name description
                                          default-true-or-false
                                          manual-true-or-false)))
                      (else #f)))
                   (('section (? (cut equal? <> section-type) lib) parameters)
                    (make-cabal-library (dependencies parameters)))
                   (_ #f))
              sexp))

(define* (lookup-join key-values-list key #:optional (delimiter " "))
  "Lookup and joint all values pertaining to keys of value KEY in
KEY-VALUES-LIST.  The optional DELIMITER is used to specify a delimiter string
to be added between the values found in different key/value pairs."
  (string-join
   (filter-map (cut match <>
                    (((? (lambda(x) (equal? x key))) value)
                     (string-join value delimiter))
                    (_ #f))
               key-values-list)
   delimiter))

(define dependency-name-version-rx
  (make-regexp "([a-zA-Z0-9_-]+) *(.*)"))

(define* (dependencies key-values-list #:optional (key "build-depends"))
  "Return a list of 'cabal-dependency' objects for the dependencies found in
KEY-VALUES-LIST."
  (let ((deps (string-tokenize (lookup-join key-values-list key ",")
                               (char-set-complement (char-set #\,)))))
    (map (lambda (d)
           (let ((rx-result (regexp-exec dependency-name-version-rx d)))
             (make-cabal-dependency
              (match:substring rx-result 1)
              (match:substring rx-result 2))))
         deps)))

;;; cabal.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 cpan)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module ((ice-9 popen) #:select (open-pipe* close-pipe))
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (json)
  #:use-module (gcrypt hash)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix base32)
  #:use-module (guix ui)
  #:use-module ((guix download) #:select (download-to-store url-fetch))
  #:use-module ((guix import utils) #:select (factorize-uri))
  #:use-module (guix import json)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix derivations)
  #:export (cpan-dependency?
            cpan-dependency-relationship
            cpan-dependency-phase
            cpan-dependency-module
            cpan-dependency-version

            cpan-release?
            cpan-release-license
            cpan-release-author
            cpan-release-version
            cpan-release-module
            cpan-release-distribution
            cpan-release-download-url
            cpan-release-abstract
            cpan-release-home-page
            cpan-release-dependencies
            json->cpan-release

            cpan-fetch
            cpan->guix-package
            metacpan-url->mirror-url
            %cpan-updater

            %metacpan-base-url))

;;; Commentary:
;;;
;;; Generate a package declaration template for the latest version of a CPAN
;;; module, using meta-data from metacpan.org.
;;;
;;; Code:

(define %metacpan-base-url
  ;; Base URL of the MetaCPAN API.
  (make-parameter "https://fastapi.metacpan.org/v1/"))

;; Dependency of a "release".
(define-json-mapping <cpan-dependency> make-cpan-dependency cpan-dependency?
  json->cpan-dependency
  (relationship cpan-dependency-relationship "relationship"
                string->symbol)                   ;requires | suggests
  (phase        cpan-dependency-phase "phase"
                string->symbol)          ;develop | configure | test | runtime
  (module       cpan-dependency-module)           ;string
  (version      cpan-dependency-version))         ;string

;; Release as returned by <https://fastapi.metacpan.org/v1/release/PKG>.
(define-json-mapping <cpan-release> make-cpan-release cpan-release?
  json->cpan-release
  (license      cpan-release-license)
  (author       cpan-release-author)
  (version      cpan-release-version "version"
                (match-lambda
                  ((? number? version)
                   ;; Version is sometimes not quoted in the module json, so
                   ;; it gets imported into Guile as a number, so convert it
                   ;; to a string (example: "X11-Protocol-Other").
                   (number->string version))
                  ((? string? version)
                   ;; Sometimes we get a "v" prefix.  Strip it.
                   (if (string-prefix? "v" version)
                       (string-drop version 1)
                       version))))
  (module       cpan-release-module "main_module") ;e.g., "Test::Script"
  (distribution cpan-release-distribution)         ;e.g., "Test-Script"
  (download-url cpan-release-download-url "download_url")
  (abstract     cpan-release-abstract "abstract")
  (home-page    cpan-release-home-page "resources"
                (match-lambda
                  (#f #f)
                  ((? unspecified?) #f)
                  ((lst ...) (assoc-ref lst "homepage"))))
  (dependencies cpan-release-dependencies "dependency"
                (lambda (vector)
                  (map json->cpan-dependency (vector->list vector)))))

(define string->license
  (match-lambda
   ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
   ;; Some licenses are excluded based on their absense from (guix licenses).
   ("agpl_3" 'agpl3)
   ;; apache_1_1
   ("apache_2_0" 'asl2.0)
   ;; artistic_1
   ("artistic_2" 'artistic2.0)
   ("bsd" 'bsd-3)
   ("freebsd" 'bsd-2)
   ;; gfdl_1_2
   ("gfdl_1_3" 'fdl1.3+)
   ("gpl_1" 'gpl1)
   ("gpl_2" 'gpl2)
   ("gpl_3" 'gpl3)
   ("lgpl_2_1" 'lgpl2.1)
   ("lgpl_3_0" 'lgpl3)
   ("mit" 'x11)
   ;; mozilla_1_0
   ("mozilla_1_1" 'mpl1.1)
   ("openssl" 'openssl)
   ("perl_5" 'perl-license)   ;GPL1+ and Artistic 1
   ("qpl_1_0" 'qpl)
   ;; ssleay
   ;; sun
   ("zlib" 'zlib)
   (#(x) (string->license x))
   (#(lst ...) `(list ,@(map string->license lst)))
   (_ #f)))

(define (module->name module)
  "Transform a 'module' name into a 'release' name"
  (regexp-substitute/global #f "::" module 'pre "-" 'post))

(define (module->dist-name module)
  "Return the base distribution module for a given module.  E.g. the 'ok'
module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
return \"Test-Simple\""
  (assoc-ref (json-fetch (string-append
                          (%metacpan-base-url) "/module/"
                          module
                          "?fields=distribution"))
             "distribution"))

(define (package->upstream-name package)
  "Return the CPAN name of PACKAGE."
  (let* ((properties (package-properties package))
         (upstream-name (and=> properties
                               (cut assoc-ref <> 'upstream-name))))
    (or upstream-name
        (match (package-source package)
          ((? origin? origin)
           (match (origin-uri origin)
             ((or (? string? url) (url _ ...))
              (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
                (#f #f)
                (m (match:substring m 1))))
             (_ #f)))
          (_ #f)))))

(define (cpan-fetch name)
  "Return a <cpan-release> record for Perl module MODULE,
or #f on failure.  MODULE should be the distribution name, such as
\"Test-Script\" for the \"Test::Script\" module."
  ;; This API always returns the latest release of the module.
  (and=> (json-fetch (string-append (%metacpan-base-url) "/release/"
                                    name))
         json->cpan-release))

(define (cpan-home name)
  (string-append "https://metacpan.org/release/" name))

(define (metacpan-url->mirror-url url)
  "Replace 'https://cpan.metacpan.org' in URL with 'mirror://cpan'."
  (regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
                            url
                            'pre "mirror://cpan" 'post))

(define cpan-source-url
  (compose metacpan-url->mirror-url cpan-release-download-url))

(define (perl-package)
  "Return the 'perl' package.  This is a lazy reference so that we don't
depend on (gnu packages perl)."
  (module-ref (resolve-interface '(gnu packages perl)) 'perl))

(define %corelist
  (delay
    (let* ((perl (with-store store
                   (derivation->output-path
                    (package-derivation store (perl-package)))))
           (core (string-append perl "/bin/corelist")))
      (and (access? core X_OK)
           core))))

(define core-module?
  (let ((rx (make-regexp
             (string-append "released with perl v?([0-9\\.]*)"
                            "(.*and removed from v?([0-9\\.]*))?"))))
    (lambda (name)
      (define perl-version
        (package-version (perl-package)))

      (define (version-between? lower version upper)
        (and (version>=? version lower)
             (or (not upper)
                 (version>? upper version))))
      (and (force %corelist)
           (parameterize ((current-error-port (%make-void-port "w")))
             (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name)))
               (let loop ()
                 (let ((line (read-line corelist)))
                   (if (eof-object? line)
                       (begin (close-pipe corelist) #f)
                       (or (and=> (regexp-exec rx line)
                                  (lambda (m)
                                    (let ((first (match:substring m 1))
                                          (last  (match:substring m 3)))
                                      (version-between?
                                       first perl-version last))))
                           (loop)))))))))))

(define (cpan-module->sexp release)
  "Return the 'package' s-expression for a CPAN module from the release data
in RELEASE, a <cpan-release> record."
  (define name
    (cpan-release-distribution release))

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

  (define version (cpan-release-version release))
  (define source-url (cpan-source-url release))

  (define (convert-inputs phases)
    ;; Convert phase dependencies into a list of name/variable pairs.
    (match (filter-map (lambda (dependency)
                         (and (memq (cpan-dependency-phase dependency)
                                    phases)
                              (cpan-dependency-module dependency)))
                       (cpan-release-dependencies release))
      ((inputs ...)
       (sort
        (delete-duplicates
         ;; Listed dependencies may include core modules.  Filter those out.
         (filter-map (match-lambda
                       ("perl" #f)                ;implicit dependency
                       ((? core-module?) #f)
                       (module
                         (let ((name (guix-name (module->dist-name module))))
                           (list name
                                 (list 'unquote (string->symbol name))))))
                     inputs))
        (lambda args
          (match args
            (((a _ ...) (b _ ...))
             (string<? a b))))))))

  (define (maybe-inputs guix-name inputs)
    (match 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 perl-build-system)
       ,@(maybe-inputs 'native-inputs
                       ;; "runtime" may also be needed here.  See
                       ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
                       ;; which says they are required during building.  We
                       ;; have not yet had a need for cross-compiled perl
                       ;; modules, however, so we leave it out.
                       (convert-inputs '(configure build test)))
       ,@(maybe-inputs 'propagated-inputs
                       (convert-inputs '(runtime)))
       (home-page ,(cpan-home name))
       (synopsis ,(cpan-release-abstract release))
       (description fill-in-yourself!)
       (license ,(string->license (cpan-release-license release))))))

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

(define cpan-package?
  (let ((cpan-rx (make-regexp (string-append "("
                                             "mirror://cpan" "|"
                                             "https?://www.cpan.org" "|"
                                             "https?://cpan.metacpan.org"
                                             ")"))))
    (url-predicate (cut regexp-exec cpan-rx <>))))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (match (cpan-fetch (package->upstream-name package))
    (#f #f)
    (release
     (let ((core-inputs
            (match (package-direct-inputs package)
              (((_ inputs _ ...) ...)
               (filter-map (match-lambda
                             ((and (? package?)
                                   (? cpan-package?)
                                   (= package->upstream-name
                                      (? core-module? name)))
                              name)
                             (else #f))
                           inputs)))))
       ;; Warn about inputs that are part of perl's core
       (unless (null? core-inputs)
         (for-each (lambda (module)
                     (warning (G_ "input '~a' of ~a is in Perl core~%")
                              module (package-name package)))
                   core-inputs)))
     (let ((version (cpan-release-version release))
           (url     (cpan-source-url release)))
       (upstream-source
        (package (package-name package))
        (version version)
        (urls (list url)))))))

(define %cpan-updater
  (upstream-updater
   (name 'cpan)
   (description "Updater for CPAN packages")
   (pred cpan-package?)
   (latest latest-release)))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
;;;
;;; 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 cran)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 popen)
  #:use-module ((ice-9 rdelim) #:select (read-string read-line))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 receive)
  #:use-module (web uri)
  #:use-module (guix memoization)
  #:use-module (guix http-client)
  #:use-module (gcrypt hash)
  #:use-module (guix store)
  #:use-module ((guix serialization) #:select (write-file))
  #:use-module (guix base32)
  #:use-module ((guix download) #:select (download-to-store))
  #:use-module (guix import utils)
  #:use-module ((guix build utils)
                #:select (find-files
                          delete-file-recursively
                          with-directory-excursion))
  #:use-module (guix utils)
  #:use-module (guix git)
  #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
  #:use-module (guix ui)
  #:use-module (guix upstream)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:export (%input-style

            cran->guix-package
            bioconductor->guix-package
            cran-recursive-import
            %cran-updater
            %bioconductor-updater
            %bioconductor-version

            cran-package?
            bioconductor-package?
            bioconductor-data-package?
            bioconductor-experiment-package?

            description->alist
            description->package))

;;; Commentary:
;;;
;;; Generate a package declaration template for the latest version of an R
;;; package on CRAN, using the DESCRIPTION file downloaded from
;;; cran.r-project.org.
;;;
;;; Code:

(define %input-style
  (make-parameter 'variable)) ; or 'specification

(define string->license
  (match-lambda
   ("AGPL-3" 'agpl3+)
   ("Artistic-2.0" 'artistic2.0)
   ("Apache License 2.0" 'asl2.0)
   ("BSD_2_clause" 'bsd-2)
   ("BSD_2_clause + file LICENSE" 'bsd-2)
   ("BSD_3_clause" 'bsd-3)
   ("BSD_3_clause + file LICENSE" 'bsd-3)
   ("GPL" '(list gpl2+ gpl3+))
   ("GPL (>= 2)" 'gpl2+)
   ("GPL (>= 3)" 'gpl3+)
   ("GPL-2" 'gpl2)
   ("GPL-3" 'gpl3)
   ("LGPL-2" 'lgpl2.0)
   ("LGPL-2.1" 'lgpl2.1)
   ("LGPL-3" 'lgpl3)
   ("LGPL (>= 2)" 'lgpl2.0+)
   ("LGPL (>= 2.1)" 'lgpl2.1+)
   ("LGPL (>= 3)" 'lgpl3+)
   ("MIT" 'expat)
   ("MIT + file LICENSE" 'expat)
   ((x) (string->license x))
   ((lst ...) `(list ,@(map string->license lst)))
   (_ #f)))

(define (description->alist description)
  "Convert a DESCRIPTION string into an alist."
  (let ((lines (string-split description #\newline))
        (parse (lambda (line acc)
                 (if (string-null? line) acc
                     ;; Keys usually start with a capital letter and end with
                     ;; ":".  There are some exceptions, unfortunately (such
                     ;; as "biocViews").  There are no blanks in a key.
                     (if (string-match "^[A-Za-z][^ :]+:( |\n|$)" line)
                         ;; New key/value pair
                         (let* ((pos   (string-index line #\:))
                                (key   (string-take line pos))
                                (value (string-drop line (+ 1 pos))))
                           (cons (cons key
                                       (string-trim-both value))
                                 acc))
                         ;; This is a continuation of the previous pair
                         (match-let ((((key . value) . rest) acc))
                           (cons (cons key (string-join
                                            (list value
                                                  (string-trim-both line))))
                                 rest)))))))
    (fold parse '() lines)))

(define (format-inputs names)
  "Generate a sorted list of package inputs from a list of package NAMES."
  (map (lambda (name)
         (case (%input-style)
           ((specification)
            (list name (list 'unquote (list 'specification->package name))))
           (else
            (list name (list 'unquote (string->symbol name))))))
       (sort names string-ci<?)))

(define* (maybe-inputs package-inputs #:optional (type 'inputs))
  "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
package definition."
  (match package-inputs
    (()
     '())
    ((package-inputs ...)
     `((,type (,'quasiquote ,(format-inputs package-inputs)))))))

(define %cran-url "https://cran.r-project.org/web/packages/")
(define %cran-canonical-url "https://cran.r-project.org/package=")
(define %bioconductor-url "https://bioconductor.org/packages/")

;; The latest Bioconductor release is 3.13.  Bioconductor packages should be
;; updated together.
(define %bioconductor-version "3.13")

(define* (bioconductor-packages-list-url #:optional type)
  (string-append "https://bioconductor.org/packages/"
                 %bioconductor-version
                 (match type
                   ('annotation "/data/annotation")
                   ('experiment "/data/experiment")
                   (_ "/bioc"))
                 "/src/contrib/PACKAGES"))

(define* (bioconductor-packages-list #:optional type)
  "Return the latest version of package NAME for the current bioconductor
release."
  (let ((url (string->uri (bioconductor-packages-list-url type))))
    (guard (c ((http-get-error? c)
               (format (current-error-port)
                       "error: failed to retrieve list of packages from ~s: ~a (~s)~%"
                       (uri->string (http-get-error-uri c))
                       (http-get-error-code c)
                       (http-get-error-reason c))
               #f))
      ;; Split the big list on empty lines, then turn each chunk into an
      ;; alist of attributes.
      (map (lambda (chunk)
             (description->alist (string-join chunk "\n")))
           (let* ((port  (http-fetch/cached url))
                  (lines (read-lines port)))
             (close-port port)
             (chunk-lines lines))))))

(define* (latest-bioconductor-package-version name #:optional type)
  "Return the version string corresponding to the latest release of the
bioconductor package NAME, or #F if the package is unknown."
  (and=> (find (lambda (meta)
                 (string=? (assoc-ref meta "Package") name))
               (bioconductor-packages-list type))
         (cut assoc-ref <> "Version")))

;; XXX taken from (guix scripts hash)
(define (vcs-file? file stat)
  (case (stat:type stat)
    ((directory)
     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
    ((regular)
     ;; Git sub-modules have a '.git' file that is a regular text file.
     (string=? (basename file) ".git"))
    (else
     #f)))

;; Little helper to download URLs only once.
(define download
  (memoize
   (lambda* (url #:key method)
     (with-store store
       (cond
        ((eq? method 'git)
         (latest-repository-commit store url))
        ((eq? method 'hg)
         (call-with-temporary-directory
          (lambda (dir)
            (unless (zero? (system* "hg" "clone" url dir))
              (leave (G_ "~A: hg download failed~%") url))
            (with-directory-excursion dir
              (let* ((port (open-pipe* OPEN_READ "hg" "id" "--id"))
                     (changeset (string-trim-right (read-string port))))
                (close-pipe port)
                (for-each delete-file-recursively
                          (find-files dir "^\\.hg$" #:directories? #t))
                (let ((store-directory
                       (add-to-store store (basename url) #t "sha256" dir)))
                  (values store-directory changeset)))))))
        (else (download-to-store store url)))))))

(define (fetch-description repository name)
  "Return an alist of the contents of the DESCRIPTION file for the R package
NAME in the given REPOSITORY, or #f in case of failure.  NAME is
case-sensitive."
  (case repository
    ((cran)
     (let ((url (string-append %cran-url name "/DESCRIPTION")))
       (guard (c ((http-get-error? c)
                  (format (current-error-port)
                          "error: failed to retrieve package information \
from ~s: ~a (~s)~%"
                          (uri->string (http-get-error-uri c))
                          (http-get-error-code c)
                          (http-get-error-reason c))
                  #f))
         (let* ((port   (http-fetch url))
                (result (description->alist (read-string port))))
           (close-port port)
           result))))
    ((bioconductor)
     ;; Currently, the bioconductor project does not offer a way to access a
     ;; package's DESCRIPTION file over HTTP, so we determine the version,
     ;; download the source tarball, and then extract the DESCRIPTION file.
     (and-let* ((type    (or
                          (and (latest-bioconductor-package-version name) #t)
                          (and (latest-bioconductor-package-version name 'annotation) 'annotation)
                          (and (latest-bioconductor-package-version name 'experiment) 'experiment)))
                (version (latest-bioconductor-package-version name type))
                (url     (car (bioconductor-uri name version type)))
                (tarball (download url)))
       (call-with-temporary-directory
        (lambda (dir)
          (parameterize ((current-error-port (%make-void-port "rw+"))
                         (current-output-port (%make-void-port "rw+")))
            (and (zero? (system* "tar" "--wildcards" "-x"
                                 "--strip-components=1"
                                 "-C" dir
                                 "-f" tarball "*/DESCRIPTION"))
                 (and=> (description->alist (with-input-from-file
                                                (string-append dir "/DESCRIPTION") read-string))
                        (lambda (meta)
                          (if (boolean? type) meta
                              (cons `(bioconductor-type . ,type) meta))))))))))
    ((git)
     (and (string-prefix? "http" name)
          ;; Download the git repository at "NAME"
          (call-with-values
              (lambda () (download name #:method 'git))
            (lambda (dir commit)
              (and=> (description->alist (with-input-from-file
                                             (string-append dir "/DESCRIPTION") read-string))
                     (lambda (meta)
                       (cons* `(git . ,name)
                              `(git-commit . ,commit)
                              meta)))))))
    ((hg)
     (and (string-prefix? "http" name)
          ;; Download the mercurial repository at "NAME"
          (call-with-values
              (lambda () (download name #:method 'hg))
            (lambda (dir changeset)
              (and=> (description->alist (with-input-from-file
                                             (string-append dir "/DESCRIPTION") read-string))
                     (lambda (meta)
                       (cons* `(hg . ,name)
                              `(hg-changeset . ,changeset)
                              meta)))))))))

(define (listify meta field)
  "Look up FIELD in the alist META.  If FIELD contains a comma-separated
string, turn it into a list and strip off parenthetic expressions.  Return the
empty list when the FIELD cannot be found."
  (let ((value (assoc-ref meta field)))
    (if (not value)
        '()
        ;; Strip off parentheses
        (let ((items (string-split (regexp-substitute/global
                                    #f "( *\\([^\\)]+\\)) *"
                                    value 'pre 'post)
                                   #\,)))
          (remove (lambda (item)
                    (or (string-null? item)
                        ;; When there is whitespace inside of items it is
                        ;; probably because this was not an actual list to
                        ;; begin with.
                        (string-any char-set:whitespace item)))
                  (map string-trim-both items))))))

;; Trick Guile 3 so that it keeps the 'listify' binding accessible *and*
;; private even though this module is declarative.
(set! listify listify)

(define default-r-packages
  (list "base"
        "compiler"
        "datasets"
        "grDevices"
        "graphics"
        "grid"
        "methods"
        "parallel"
        "splines"
        "stats"
        "stats4"
        "tcltk"
        "tools"
        "translations"
        "utils"))

;; The field for system dependencies is often abused to specify non-package
;; dependencies (such as c++11).  This list is used to ignore them.
(define invalid-packages
  (list "c++11"
        "c++14"
        "linux"
        "getopt::long"
        "xquartz"))

(define cran-guix-name (cut guix-name "r-" <>))

(define (tarball-needs-fortran? tarball)
  "Check if the TARBALL contains Fortran source files."
  (define (check pattern)
    (parameterize ((current-error-port (%make-void-port "rw+"))
                   (current-output-port (%make-void-port "rw+")))
      (zero? (system* "tar" "--wildcards" "--list" pattern "-f" tarball))))
  (or (check "*.f90")
      (check "*.f95")
      (check "*.f")))

(define (directory-needs-fortran? dir)
  "Check if the directory DIR contains Fortran source files."
  (match (find-files dir "\\.f(90|95)$")
    (() #f)
    (_ #t)))

(define (needs-fortran? thing tarball?)
  "Check if the THING contains Fortran source files."
  (if tarball?
      (tarball-needs-fortran? thing)
      (directory-needs-fortran? thing)))

(define (files-match-pattern? directory regexp . file-patterns)
  "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match
the given REGEXP."
  (let ((pattern (make-regexp regexp)))
    (any (lambda (file)
           (call-with-input-file file
             (lambda (port)
               (let loop ()
                 (let ((line (read-line port)))
                   (cond
                    ((eof-object? line) #f)
                    ((regexp-exec pattern line) #t)
                    (else (loop))))))))
         (apply find-files directory file-patterns))))

(define (tarball-files-match-pattern? tarball regexp . file-patterns)
  "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL
match the given REGEXP."
  (call-with-temporary-directory
   (lambda (dir)
     (parameterize ((current-error-port (%make-void-port "rw+")))
       (apply system* "tar"
              "xf" tarball "-C" dir
              `("--wildcards" ,@file-patterns)))
     (files-match-pattern? dir regexp))))

(define (directory-needs-zlib? dir)
  "Return #T if any of the Makevars files in the src directory DIR contain a
zlib linker flag."
  (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)"))

(define (tarball-needs-zlib? tarball)
  "Return #T if any of the Makevars files in the src directory of the TARBALL
contain a zlib linker flag."
  (tarball-files-match-pattern?
   tarball "-lz"
   "*/src/Makevars*" "*/src/configure*" "*/configure*"))

(define (needs-zlib? thing tarball?)
  "Check if the THING contains files indicating a dependency on zlib."
  (if tarball?
      (tarball-needs-zlib? thing)
      (directory-needs-zlib? thing)))

(define (directory-needs-pkg-config? dir)
  "Return #T if any of the Makevars files in the src directory DIR reference
the pkg-config tool."
  (files-match-pattern? dir "pkg-config"
                        "(Makevars.*|configure.*)"))

(define (tarball-needs-pkg-config? tarball)
  "Return #T if any of the Makevars files in the src directory of the TARBALL
reference the pkg-config tool."
  (tarball-files-match-pattern?
   tarball "pkg-config"
   "*/src/Makevars*" "*/src/configure*" "*/configure*"))

(define (needs-pkg-config? thing tarball?)
  "Check if the THING contains files indicating a dependency on pkg-config."
  (if tarball?
      (tarball-needs-pkg-config? thing)
      (directory-needs-pkg-config? thing)))

(define (needs-knitr? meta)
  (member "knitr" (listify meta "VignetteBuilder")))

;; XXX adapted from (guix scripts hash)
(define (file-hash file select? recursive?)
  ;; Compute the hash of FILE.
  (if recursive?
      (let-values (((port get-hash) (open-sha256-port)))
        (write-file file port #:select? select?)
        (force-output port)
        (get-hash))
      (call-with-input-file file port-sha256)))

(define (description->package repository meta)
  "Return the `package' s-expression for an R package published on REPOSITORY
from the alist META, which was derived from the R package's DESCRIPTION file."
  (let* ((base-url   (case repository
                       ((cran)         %cran-url)
                       ((bioconductor) %bioconductor-url)
                       ((git)          #f)
                       ((hg)           #f)))
         (canonical-url-base (case repository
                               ((cran)         %cran-canonical-url)
                               ((bioconductor) %bioconductor-url)
                               ((git)          #f)))
         (uri-helper (case repository
                       ((cran)         cran-uri)
                       ((bioconductor) bioconductor-uri)
                       ((git)          #f)
                       ((hg)           #f)))
         (name       (assoc-ref meta "Package"))
         (synopsis   (assoc-ref meta "Title"))
         (version    (assoc-ref meta "Version"))
         (license    (string->license (assoc-ref meta "License")))
         ;; Some packages have multiple home pages.  Some have none.
         (home-page  (case repository
                       ((git) (assoc-ref meta 'git))
                       ((hg)  (assoc-ref meta 'hg))
                       (else (match (listify meta "URL")
                               ((url rest ...) url)
                               (_ (string-append canonical-url-base name))))))
         (source-url (case repository
                       ((git) (assoc-ref meta 'git))
                       ((hg)  (assoc-ref meta 'hg))
                       (else
                        (match (apply uri-helper name version
                                      (case repository
                                        ((bioconductor)
                                         (list (assoc-ref meta 'bioconductor-type)))
                                        (else '())))
                          ((url rest ...) url)
                          ((? string? url) url)
                          (_ #f)))))
         (git?       (assoc-ref meta 'git))
         (hg?        (assoc-ref meta 'hg))
         (source     (download source-url #:method (cond
                                                    (git? 'git)
                                                    (hg? 'hg)
                                                    (else #f))))
         (sysdepends (append
                      (if (needs-zlib? source (not (or git? hg?))) '("zlib") '())
                      (filter (lambda (name)
                                (not (member name invalid-packages)))
                              (map string-downcase (listify meta "SystemRequirements")))))
         (propagate  (filter (lambda (name)
                               (not (member name (append default-r-packages
                                                         invalid-packages))))
                             (lset-union equal?
                                         (listify meta "Imports")
                                         (listify meta "LinkingTo")
                                         (delete "R"
                                                 (listify meta "Depends")))))
         (package
           `(package
              (name ,(cran-guix-name name))
              (version ,(case repository
                          ((git)
                           `(git-version ,version revision commit))
                          ((hg)
                           `(string-append ,version "-" revision "." changeset))
                          (else version)))
              (source (origin
                        (method ,(cond
                                  (git? 'git-fetch)
                                  (hg?  'hg-fetch)
                                  (else 'url-fetch)))
                        (uri ,(case repository
                                ((git)
                                 `(git-reference
                                   (url ,(assoc-ref meta 'git))
                                   (commit commit)))
                                ((hg)
                                 `(hg-reference
                                   (url ,(assoc-ref meta 'hg))
                                   (changeset changeset)))
                                (else
                                 `(,(procedure-name uri-helper) ,name version
                                   ,@(or (and=> (assoc-ref meta 'bioconductor-type)
                                                (lambda (type)
                                                  (list (list 'quote type))))
                                         '())))))
                        ,@(cond
                           (git?
                            '((file-name (git-file-name name version))))
                           (hg?
                            '((file-name (string-append name "-" version "-checkout"))))
                           (else '()))
                        (sha256
                         (base32
                          ,(bytevector->nix-base32-string
                            (case repository
                              ((git)
                               (file-hash source (negate vcs-file?) #t))
                              ((hg)
                               (file-hash source (negate vcs-file?) #t))
                              (else (file-sha256 source))))))))
              ,@(if (not (and git? hg?
                              (equal? (string-append "r-" name)
                                      (cran-guix-name name))))
                    `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
                    '())
              (build-system r-build-system)
              ,@(maybe-inputs sysdepends)
              ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
              ,@(maybe-inputs
                 `(,@(if (needs-fortran? source (not (or git? hg?)))
                         '("gfortran") '())
                   ,@(if (needs-pkg-config? source (not (or git? hg?)))
                         '("pkg-config") '())
                   ,@(if (needs-knitr? meta)
                         '("r-knitr") '()))
                 'native-inputs)
              (home-page ,(if (string-null? home-page)
                              (string-append base-url name)
                              home-page))
              (synopsis ,synopsis)
              (description ,(beautify-description (or (assoc-ref meta "Description")
                                                      "")))
              (license ,license))))
    (values
     (case repository
       ((git)
        `(let ((commit ,(assoc-ref meta 'git-commit))
               (revision "1"))
           ,package))
       ((hg)
        `(let ((changeset ,(assoc-ref meta 'hg-changeset))
               (revision "1"))
           ,package))
       (else package))
     propagate)))

(define cran->guix-package
  (memoize
   (lambda* (package-name #:key (repo 'cran) version)
     "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
s-expression corresponding to that package, or #f on failure."
     (let ((description (fetch-description repo package-name)))
       (if description
           (description->package repo description)
           (case repo
             ((git)
              ;; Retry import from Bioconductor
              (cran->guix-package package-name #:repo 'bioconductor))
             ((hg)
              ;; Retry import from Bioconductor
              (cran->guix-package package-name #:repo 'bioconductor))
             ((bioconductor)
              ;; Retry import from CRAN
              (cran->guix-package package-name #:repo 'cran))
             (else
              (raise (condition
                      (&message
                       (message "couldn't find meta-data for R package")))))))))))

(define* (cran-recursive-import package-name #:key (repo 'cran))
  (recursive-import package-name
                    #:repo repo
                    #:repo->guix-package cran->guix-package
                    #:guix-name cran-guix-name))

;;;
;;; Updater.
;;;

(define (package->upstream-name package)
  "Return the upstream name of the PACKAGE."
  (let* ((properties (package-properties package))
         (upstream-name (and=> properties
                               (cut assoc-ref <> 'upstream-name))))
    (if upstream-name
        upstream-name
        (match (package-source package)
          ((? origin? origin)
           (match (origin-uri origin)
             ((or (? string? url) (url _ ...))
              (let ((end   (string-rindex url #\_))
                    (start (string-rindex url #\/)))
                ;; The URL ends on
                ;; (string-append "/" name "_" version ".tar.gz")
                (and start end (substring url (+ start 1) end))))
             (_ #f)))
          (_ #f)))))

(define (latest-cran-release pkg)
  "Return an <upstream-source> for the latest release of the package PKG."

  (define upstream-name
    (package->upstream-name pkg))

  (define meta
    (fetch-description 'cran upstream-name))

  (and meta
       (let ((version (assoc-ref meta "Version")))
         ;; CRAN does not provide signatures.
         (upstream-source
          (package (package-name pkg))
          (version version)
          (urls (cran-uri upstream-name version))
          (input-changes
           (changed-inputs pkg
                           (description->package 'cran meta)))))))

(define (latest-bioconductor-release pkg)
  "Return an <upstream-source> for the latest release of the package PKG."

  (define upstream-name
    (package->upstream-name pkg))

  (define version
    (latest-bioconductor-package-version upstream-name))

  (and version
       ;; Bioconductor does not provide signatures.
       (upstream-source
        (package (package-name pkg))
        (version version)
        (urls (bioconductor-uri upstream-name version))
        (input-changes
         (changed-inputs
          pkg
          (cran->guix-package upstream-name #:repo 'bioconductor))))))

(define (cran-package? package)
  "Return true if PACKAGE is an R package from CRAN."
  (and (string-prefix? "r-" (package-name package))
       ;; Check if the upstream name can be extracted from package uri.
       (package->upstream-name package)
       ;; Check if package uri(s) are prefixed by "mirror://cran".
       ((url-predicate (cut string-prefix? "mirror://cran" <>)) package)))

(define (bioconductor-package? package)
  "Return true if PACKAGE is an R package from Bioconductor."
  (let ((predicate (lambda (uri)
                     (and (string-prefix? "https://bioconductor.org" uri)
                          ;; Data packages are neither listed in SVN nor on
                          ;; the Github mirror, so we have to exclude them
                          ;; from the set of bioconductor packages that can be
                          ;; updated automatically.
                          (not (string-contains uri "/data/annotation/"))
                          ;; Experiment packages are in a separate repository.
                          (not (string-contains uri "/data/experiment/"))))))
    (and (string-prefix? "r-" (package-name package))
         ((url-predicate predicate) package))))

(define (bioconductor-data-package? package)
  "Return true if PACKAGE is an R data package from Bioconductor."
  (let ((predicate (lambda (uri)
                     (and (string-prefix? "https://bioconductor.org" uri)
                          (string-contains uri "/data/annotation/")))))
    (and (string-prefix? "r-" (package-name package))
         ((url-predicate predicate) package))))

(define (bioconductor-experiment-package? package)
  "Return true if PACKAGE is an R experiment package from Bioconductor."
  (let ((predicate (lambda (uri)
                     (and (string-prefix? "https://bioconductor.org" uri)
                          (string-contains uri "/data/experiment/")))))
    (and (string-prefix? "r-" (package-name package))
         ((url-predicate predicate) package))))

(define %cran-updater
  (upstream-updater
   (name 'cran)
   (description "Updater for CRAN packages")
   (pred cran-package?)
   (latest latest-cran-release)))

(define %bioconductor-updater
  (upstream-updater
   (name 'bioconductor)
   (description "Updater for Bioconductor packages")
   (pred bioconductor-package?)
   (latest latest-bioconductor-release)))

;;; cran.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;;
;;; 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 crate)
  #:use-module (guix base32)
  #:use-module (guix build-system cargo)
  #:use-module ((guix download) #:prefix download:)
  #:use-module (gcrypt hash)
  #:use-module (guix http-client)
  #:use-module (guix import json)
  #:use-module (guix import utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix memoization)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (gnu packages)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-71)
  #:export (crate->guix-package
            guix-package->crate-name
            string->license
            crate-recursive-import
            %crate-updater))

;;;
;;; Interface to https://crates.io/api/v1.
;;;

;; Crates.  A crate is essentially a "package".  It can have several
;; "versions", each of which has its own set of dependencies, license,
;; etc.--see <crate-version> below.
(define-json-mapping <crate> make-crate crate?
  json->crate
  (name          crate-name)                      ;string
  (latest-version crate-latest-version "max_version") ;string
  (home-page     crate-home-page "homepage")      ;string | #nil
  (repository    crate-repository)                ;string
  (description   crate-description)               ;string
  (keywords      crate-keywords                   ;list of strings
                 "keywords" vector->list)
  (categories    crate-categories                 ;list of strings
                 "categories" vector->list)
  (versions      crate-versions "actual_versions" ;list of <crate-version>
                 (lambda (vector)
                   (map json->crate-version
                        (vector->list vector))))
  (links         crate-links))                    ;alist

;; Crate version.
(define-json-mapping <crate-version> make-crate-version crate-version?
  json->crate-version
  (id            crate-version-id)                ;integer
  (number        crate-version-number "num")      ;string
  (download-path crate-version-download-path "dl_path") ;string
  (readme-path   crate-version-readme-path "readme_path") ;string
  (license       crate-version-license "license") ;string
  (links         crate-version-links))            ;alist

;; Crate dependency.  Each dependency (each edge in the graph) is annotated as
;; being a "normal" dependency or a development dependency.  There also
;; information about the minimum required version, such as "^0.0.41".
(define-json-mapping <crate-dependency> make-crate-dependency
  crate-dependency?
  json->crate-dependency
  (id            crate-dependency-id "crate_id")  ;string
  (kind          crate-dependency-kind "kind"     ;'normal | 'dev | 'build
                 string->symbol)
  (requirement   crate-dependency-requirement "req")) ;string

;; Autoload Guile-Semver so we only have a soft dependency.
(module-autoload! (current-module)
		  '(semver) '(string->semver semver->string semver<?))
(module-autoload! (current-module)
		  '(semver ranges) '(string->semver-range semver-range-contains?))

(define (lookup-crate name)
  "Look up NAME on https://crates.io and return the corresopnding <crate>
record or #f if it was not found."
  (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/"
                                         name))))
    (and=> (and json (assoc-ref json "crate"))
           (lambda (alist)
             ;; The "versions" field of ALIST is simply a list of version IDs
             ;; (integers).  Here, we squeeze in the actual version
             ;; dictionaries that are not part of ALIST but are just more
             ;; convenient handled this way.
             (let ((versions (or (assoc-ref json "versions") '#())))
               (json->crate `(,@alist
                              ("actual_versions" . ,versions))))))))

(define lookup-crate* (memoize lookup-crate))

(define (crate-version-dependencies version)
  "Return the list of <crate-dependency> records of VERSION, a
<crate-version>."
  (let* ((path (assoc-ref (crate-version-links version) "dependencies"))
         (url  (string-append (%crate-base-url) path)))
    (match (assoc-ref (or (json-fetch url) '()) "dependencies")
      ((? vector? vector)
       (delete-duplicates (map json->crate-dependency (vector->list vector))))
      (_
       '()))))

;;;
;;; Converting crates to Guix packages.
;;;

(define (maybe-cargo-inputs package-names)
  (match (package-names->package-inputs package-names)
    (()
     '())
    ((package-inputs ...)
     `(#:cargo-inputs ,package-inputs))))

(define (maybe-cargo-development-inputs package-names)
  (match (package-names->package-inputs package-names)
    (()
     '())
    ((package-inputs ...)
     `(#:cargo-development-inputs ,package-inputs))))

(define (maybe-arguments arguments)
  (match arguments
    (()
     '())
    ((args ...)
     `((arguments (,'quasiquote ,args))))))

(define (version->semver-prefix version)
  "Return the version up to and including the first non-zero part"
  (first
   (map match:substring
        (list-matches "^(0+\\.){,2}[0-9]+" version))))

(define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs
                          home-page synopsis description license build?)
  "Return the `package' s-expression for a rust package with the given NAME,
VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
and LICENSE."
  (define (format-inputs inputs)
    (map
     (match-lambda
      ((name version)
       (list (crate-name->package-name name)
             (version->semver-prefix version))))
     inputs))

  (let* ((port (http-fetch (crate-uri name version)))
         (guix-name (crate-name->package-name name))
         (cargo-inputs (format-inputs cargo-inputs))
         (cargo-development-inputs (format-inputs cargo-development-inputs))
         (pkg `(package
                   (name ,guix-name)
                   (version ,version)
                   (source (origin
                             (method url-fetch)
                             (uri (crate-uri ,name version))
                             (file-name (string-append name "-" version ".tar.gz"))
                             (sha256
                              (base32
                               ,(bytevector->nix-base32-string (port-sha256 port))))))
                   (build-system cargo-build-system)
                   ,@(maybe-arguments (append (if build?
                                                 '()
                                                 '(#:skip-build? #t))
                                              (maybe-cargo-inputs cargo-inputs)
                                              (maybe-cargo-development-inputs
                                                cargo-development-inputs)))
                   (home-page ,home-page)
                   (synopsis ,synopsis)
                   (description ,(beautify-description description))
                   (license ,(match license
                               (() #f)
                               ((license) license)
                               (_ `(list ,@license)))))))
         (close-port port)
         (package->definition pkg (version->semver-prefix version))))

(define (string->license string)
  (filter-map (lambda (license)
                (and (not (string-null? license))
                     (not (any (lambda (elem) (string=? elem license))
                               '("AND" "OR" "WITH")))
                     (or (spdx-string->license license)
                         'unknown-license!)))
              (string-split string (string->char-set " /"))))

(define* (crate->guix-package crate-name #:key version include-dev-deps? repo)
  "Fetch the metadata for CRATE-NAME from crates.io, and return the
`package' s-expression corresponding to that package, or #f on failure.
When VERSION is specified, convert it into a semver range and attempt to fetch
the latest version matching this semver range; otherwise fetch the latest
version of CRATE-NAME. If INCLUDE-DEV-DEPS is true then this will also
look up the development dependencs for the given crate."

  (define (semver-range-contains-string? range version)
    (semver-range-contains? (string->semver-range range)
                            (string->semver version)))

  (define (normal-dependency? dependency)
    (or (eq? (crate-dependency-kind dependency) 'build)
        (eq? (crate-dependency-kind dependency) 'normal)))

  (define crate
    (lookup-crate* crate-name))

  (define version-number
    (and crate
         (or version
             (crate-latest-version crate))))

  ;; find the highest existing package that fulfills the semver <range>
  (define (find-package-version name range)
    (let* ((semver-range (string->semver-range range))
           (versions
            (sort
             (filter (lambda (version)
                       (semver-range-contains? semver-range version))
                     (map (lambda (pkg)
                            (string->semver (package-version pkg)))
                          (find-packages-by-name
                           (crate-name->package-name name))))
             semver<?)))
      (and (not (null-list? versions))
           (semver->string (last versions)))))

  ;; find the highest version of a crate that fulfills the semver <range>
  (define (find-crate-version crate range)
    (let* ((semver-range (string->semver-range range))
           (versions
            (sort
             (filter (lambda (entry)
                       (semver-range-contains? semver-range (first entry)))
                     (map (lambda (ver)
                            (list (string->semver (crate-version-number ver))
                                  ver))
                          (crate-versions crate)))
             (match-lambda* (((semver _) ...)
                             (apply semver<? semver))))))
      (and (not (null-list? versions))
           (second (last versions)))))

  (define (dependency-name+version dep)
    (let* ((name (crate-dependency-id dep))
           (req (crate-dependency-requirement dep))
           (existing-version (find-package-version name req)))
      (if existing-version
          (list name existing-version)
          (let* ((crate (lookup-crate* name))
                 (ver (find-crate-version crate req)))
            (list name
                  (crate-version-number ver))))))

  (define version*
    (and crate
         (find-crate-version crate version-number)))

  ;; sort and map the dependencies to a list containing
  ;; pairs of (name version)
  (define (sort-map-dependencies deps)
    (sort (map dependency-name+version
               deps)
          (match-lambda* (((name _) ...)
                          (apply string-ci<? name)))))

  (and crate version*
       (let* ((dependencies (crate-version-dependencies version*))
              (dep-crates dev-dep-crates (partition normal-dependency? dependencies))
              (cargo-inputs (sort-map-dependencies dep-crates))
              (cargo-development-inputs (if include-dev-deps?
                                            (sort-map-dependencies dev-dep-crates)
                                            '())))
         (values
          (make-crate-sexp #:build? include-dev-deps?
                           #:name crate-name
                           #:version (crate-version-number version*)
                           #:cargo-inputs cargo-inputs
                           #:cargo-development-inputs cargo-development-inputs
                           #:home-page
                           (let ((home-page (crate-home-page crate)))
                             (if (string? home-page)
                                 home-page
                                 (let ((repository (crate-repository crate)))
                                   (if (string? repository)
                                       repository
                                       ""))))
                           #:synopsis (crate-description crate)
                           #:description (crate-description crate)
                           #:license (and=> (crate-version-license version*)
                                            string->license))
          (append cargo-inputs cargo-development-inputs)))))

(define* (crate-recursive-import crate-name #:key version)
  (recursive-import crate-name
                    #:repo->guix-package (lambda* params
                      ;; download development dependencies only for the top level package
                      (let ((include-dev-deps? (equal? (car params) crate-name))
                            (crate->guix-package* (memoize crate->guix-package)))
                        (apply crate->guix-package*
                               (append params `(#:include-dev-deps? ,include-dev-deps?)))))
                    #:version version
                    #:guix-name crate-name->package-name))

(define (guix-package->crate-name package)
  "Return the crate name of PACKAGE."
  (and-let* ((origin (package-source package))
             (uri (origin-uri origin))
             (crate-url? uri)
             (len (string-length crate-url))
             (path (xsubstring uri len))
             (parts (string-split path #\/)))
    (match parts
      ((name _ ...) name))))

(define (crate-name->package-name name)
  (guix-name "rust-" name))

;;;
;;; Updater
;;;

(define crate-package?
  (url-predicate crate-url?))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (let* ((crate-name (guix-package->crate-name package))
         (crate      (lookup-crate crate-name))
         (version    (crate-latest-version crate))
         (url        (crate-uri crate-name version)))
    (upstream-source
     (package (package-name package))
     (version version)
     (urls (list url)))))

(define %crate-updater
  (upstream-updater
   (name 'crate)
   (description "Updater for crates.io packages")
   (pred crate-package?)
   (latest latest-release)))