import: hackage: Support "common" field and imports

Fixes <https://issues.guix.gnu.org/48701>.

* guix/import/cabal.scm (make-cabal-parser): Modify.
(is-common): New variable.
(lex-common): New procedure.
(is-id): Modify.
(eval-cabal): Modify.
* tests/hackage.scm ("hackage->guix-package test cabal import") New test.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 67 insertions, 2 deletions

diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index da00019297..e9a0179b3d 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -145,7 +145,7 @@ to the stack."
   (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 OCURLY)
+           (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB COMMON OCURLY)
            (left: OR)
            (left: PROPERTY AND)
            (right: ELSE NOT))
@@ -155,6 +155,7 @@ to the stack."
                 (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))
@@ -178,6 +179,10 @@ 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))
+   (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))
@@ -367,6 +372,9 @@ matching a string against the created regexp."
 (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))
 
@@ -394,7 +402,7 @@ matching a string against the created regexp."
 (define (is-id s port)
   (let ((cabal-reserved-words
          '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup"
-           "source-repository" "benchmark"))
+           "source-repository" "benchmark" "common"))
         (spaces (read-while (cut char-set-contains? char-set:blank <>) port))
         (c (peek-char port)))
     (unread-string spaces port)
@@ -469,6 +477,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-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))
@@ -570,6 +580,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-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))
@@ -796,7 +807,16 @@ 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 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'
@@ -831,6 +851,9 @@ the ordering operation and the version."
        (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
diff --git a/tests/hackage.scm b/tests/hackage.scm
index 66a13d9881..53972fc643 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -388,4 +388,46 @@ executable cabal
      #t)
     (x (pk 'fail x #f))))
 
+(define test-cabal-import
+  "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+common commons
+  build-depends:
+    HTTP       >= 4000.2.5 && < 4000.3,
+    mtl        >= 2.0      && < 3
+
+executable cabal
+  import: commons
+")
+
+(define-package-matcher match-ghc-foo-import
+  ('package
+    ('name "ghc-foo")
+    ('version "1.0.0")
+    ('source
+     ('origin
+       ('method 'url-fetch)
+       ('uri ('string-append
+              "https://hackage.haskell.org/package/foo/foo-"
+              'version
+              ".tar.gz"))
+       ('sha256
+        ('base32
+         (? string? hash)))))
+    ('build-system 'haskell-build-system)
+    ('inputs
+     ('quasiquote
+      (("ghc-http" ('unquote 'ghc-http)))))
+    ('home-page "http://test.org")
+    ('synopsis (? string?))
+    ('description (? string?))
+    ('license 'license:bsd-3)))
+
+(test-assert "hackage->guix-package test cabal import"
+  (eval-test-with-cabal test-cabal-import match-ghc-foo-import))
+
 (test-end "hackage")