[bug#32123] [PATCH] import: hackage: Support "custom-setup" field.

[bug#32123] [PATCH] import: hackage: Support "custom-setup" field.

[Danny Milosavljevic]

* guix/import/cabal.scm (make-cabal-parser): Modify.
(is-custom-setup): New variable.
(lex-custom-setup): New procedure.
(is-id): Modify.
(lex-version): Modify.
(<cabal-custom-setup>): New record type.
(eval-cabal): Modify.
(dependencies): Add parameter.
---
 guix/import/cabal.scm | 37 +++++++++++++++++++++++++++++--------
 1 file changed, 29 insertions(+), 8 deletions(-)

diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index 09130e449..1775c3879 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -140,7 +140,7 @@ to the stack."
   (lalr-parser
    ;; --- token definitions
    (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE
-           (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY)
+           (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB OCURLY)
            (left: OR)
            (left: PROPERTY AND)
            (right: ELSE NOT))
@@ -150,6 +150,7 @@ to the stack."
                 (sections source-repo)  : (append $1 (list $2))
                 (sections executables)  : (append $1 $2)
                 (sections test-suites)  : (append $1 $2)
+                (sections custom-setup) : (append $1 $2)
                 (sections benchmarks)   : (append $1 $2)
                 (sections lib-sec)      : (append $1 (list $2))
                 ()                      : '())
@@ -172,6 +173,7 @@ to the stack."
                 (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))
+   (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)
@@ -349,6 +351,9 @@ matching a string against the created regexp."
 (define is-test-suite (make-rx-matcher "^test-suite +([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))
 
@@ -368,7 +373,7 @@ matching a string against the created regexp."
 
 (define (is-id s port)
   (let ((cabal-reserved-words
-         '("if" "else" "library" "flag" "executable" "test-suite"
+         '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup"
            "source-repository" "benchmark"))
         (spaces (read-while (cut char-set-contains? char-set:blank <>) port))
         (c (peek-char port)))
@@ -392,8 +397,11 @@ matching a string against the created regexp."
 
 (define (lex-version loc port)
   (make-lexical-token 'VERSION loc
-                      (read-while char-numeric? port
-                                  (cut char=? #\. <>) char-numeric?)))
+                      (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))
@@ -435,6 +443,8 @@ string with the read characters."
 
 (define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE 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))
@@ -529,6 +539,7 @@ the current port location."
      ((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-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))
@@ -658,6 +669,12 @@ If #f use the function 'port-filename' to obtain it."
   (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-setuo-name)
+  (dependencies cabal-custom-setup-dependencies)) ; list of <cabal-dependency>
+
 (define (cabal-flags->alist flag-list)
     "Retrun an alist associating the flag name to its default value from a
 list of <cabal-flag> objects."
@@ -728,7 +745,6 @@ the ordering operation and the version."
     (let ((value (or (assoc-ref env name)
                      (assoc-ref (cabal-flags->alist (cabal-flags)) name))))
       (if (eq? value 'false) #f #t)))
-  
   (define (eval sexp)
     (match sexp
       (() '())
@@ -755,6 +771,8 @@ the ordering operation and the version."
       ;; 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)))
@@ -795,12 +813,15 @@ See the manual for limitations.")))))))
 (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, 'source-repository or 'library."
+'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
@@ -843,10 +864,10 @@ to be added between the values found in different key/value pairs."
 (define dependency-name-version-rx
   (make-regexp "([a-zA-Z0-9_-]+) *(.*)"))
 
-(define (dependencies key-values-list)
+(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 "build-depends" ",")
+  (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)))

[bug#32123] [PATCH v2 0/2] Improve Cabal importer.

[Danny Milosavljevic]

Danny Milosavljevic (2):
  import: hackage: Support "custom-setup" field.
  import: hackage: Support "-any" and "-none" version comparison
    operators.

 guix/import/cabal.scm | 68 +++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 55 insertions(+), 13 deletions(-)

[bug#32123] [PATCH v2 1/2] import: hackage: Support "custom-setup" field.

[Danny Milosavljevic]

* guix/import/cabal.scm (make-cabal-parser): Modify.
(is-custom-setup): New variable.
(lex-custom-setup): New procedure.
(is-id): Modify.
(lex-version): Modify.
(<cabal-custom-setup>): New record type.
(eval-cabal): Modify.
(dependencies): Add parameter.
---
 guix/import/cabal.scm | 37 +++++++++++++++++++++++++++++--------
 1 file changed, 29 insertions(+), 8 deletions(-)

diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index 09130e449..1775c3879 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -140,7 +140,7 @@ to the stack."
   (lalr-parser
    ;; --- token definitions
    (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE
-           (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY)
+           (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB OCURLY)
            (left: OR)
            (left: PROPERTY AND)
            (right: ELSE NOT))
@@ -150,6 +150,7 @@ to the stack."
                 (sections source-repo)  : (append $1 (list $2))
                 (sections executables)  : (append $1 $2)
                 (sections test-suites)  : (append $1 $2)
+                (sections custom-setup) : (append $1 $2)
                 (sections benchmarks)   : (append $1 $2)
                 (sections lib-sec)      : (append $1 (list $2))
                 ()                      : '())
@@ -172,6 +173,7 @@ to the stack."
                 (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))
+   (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)
@@ -349,6 +351,9 @@ matching a string against the created regexp."
 (define is-test-suite (make-rx-matcher "^test-suite +([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))
 
@@ -368,7 +373,7 @@ matching a string against the created regexp."
 
 (define (is-id s port)
   (let ((cabal-reserved-words
-         '("if" "else" "library" "flag" "executable" "test-suite"
+         '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup"
            "source-repository" "benchmark"))
         (spaces (read-while (cut char-set-contains? char-set:blank <>) port))
         (c (peek-char port)))
@@ -392,8 +397,11 @@ matching a string against the created regexp."
 
 (define (lex-version loc port)
   (make-lexical-token 'VERSION loc
-                      (read-while char-numeric? port
-                                  (cut char=? #\. <>) char-numeric?)))
+                      (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))
@@ -435,6 +443,8 @@ string with the read characters."
 
 (define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE 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))
@@ -529,6 +539,7 @@ the current port location."
      ((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-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))
@@ -658,6 +669,12 @@ If #f use the function 'port-filename' to obtain it."
   (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-setuo-name)
+  (dependencies cabal-custom-setup-dependencies)) ; list of <cabal-dependency>
+
 (define (cabal-flags->alist flag-list)
     "Retrun an alist associating the flag name to its default value from a
 list of <cabal-flag> objects."
@@ -728,7 +745,6 @@ the ordering operation and the version."
     (let ((value (or (assoc-ref env name)
                      (assoc-ref (cabal-flags->alist (cabal-flags)) name))))
       (if (eq? value 'false) #f #t)))
-  
   (define (eval sexp)
     (match sexp
       (() '())
@@ -755,6 +771,8 @@ the ordering operation and the version."
       ;; 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)))
@@ -795,12 +813,15 @@ See the manual for limitations.")))))))
 (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, 'source-repository or 'library."
+'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
@@ -843,10 +864,10 @@ to be added between the values found in different key/value pairs."
 (define dependency-name-version-rx
   (make-regexp "([a-zA-Z0-9_-]+) *(.*)"))
 
-(define (dependencies key-values-list)
+(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 "build-depends" ",")
+  (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)))

[bug#32123] [PATCH v2 2/2] import: hackage: Support "-any" and "-none" version comparison operators.

[Danny Milosavljevic]

* guix/import/cabal.scm (make-cabal-parser): Modify.
(is-any): New variable.
(is-none): New variable.
(lex-any): New procedure.
(lex-none): New procedure.
(lex-word): Modify.
(eval-cabal): Modify.
---
 guix/import/cabal.scm | 31 ++++++++++++++++++++++++++-----
 1 file changed, 26 insertions(+), 5 deletions(-)

diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index 1775c3879..cd0a2953c 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -139,7 +139,7 @@ to the stack."
   "Generate a parser for Cabal files."
   (lalr-parser
    ;; --- token definitions
-   (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE
+   (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE -ANY -NONE
            (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB OCURLY)
            (left: OR)
            (left: PROPERTY AND)
@@ -213,6 +213,10 @@ to the stack."
                 (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)))
@@ -367,6 +371,10 @@ matching a string against the created regexp."
 
 (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 "||"))
@@ -457,6 +465,10 @@ string with the read characters."
 
 (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))
@@ -524,6 +536,8 @@ LOC is the current port location."
           ((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))
@@ -711,13 +725,20 @@ 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 (and=> (with-ver-matcher-fn spec)
-                            (cut match:substring <> 2)))
-           (version (and=> (with-ver-matcher-fn spec)
-                           (cut match:substring <> 3))))
+           (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)

[bug#32123] [PATCH v2 0/2] Improve Cabal importer.

[Ludovic Courtès]

Hello Danny,

Danny Milosavljevic <dannym@scratchpost.org> skribis:

> Danny Milosavljevic (2):
>   import: hackage: Support "custom-setup" field.
>   import: hackage: Support "-any" and "-none" version comparison
>     operators.

Really great you’re working on this!  This piece of code needs love.

Could you add a test to tests/hackage.scm?  If it fixes some of the
‘guix import hackage’ limitations reported have on bugs.gnu.org/guix,
please mention it in the commit log.

Thank you!

Ludo’.

bug#32123: [PATCH v2 0/2] Improve Cabal importer.

[Danny Milosavljevic]

[-- Attachment #1: Type: text/plain, Size: 159 bytes --]

Edited commit message to mention bug# and pushed to master as

314b63e0b4372681aec165113ae2a0349eaaa357

and

ecba50bb79a49b317c4b1e718f4732b36438227f.

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]

[bug#32123] [PATCH v2 0/2] Improve Cabal importer.

[Ludovic Courtès]

Danny Milosavljevic <dannym@scratchpost.org> skribis:

> Edited commit message to mention bug# and pushed to master as
>
> 314b63e0b4372681aec165113ae2a0349eaaa357
>
> and
>
> ecba50bb79a49b317c4b1e718f4732b36438227f.

What about the test?  :-)  Or is it already covered by the existing
tests?

Thanks,
Ludo’.

[bug#32123] [PATCH v2 0/2] Improve Cabal importer.

[Danny Milosavljevic]

[-- Attachment #1: Type: text/plain, Size: 35 bytes --]

I'm at it.  Some complications ;)

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]