import: cabal: Support elif statement.

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

* guix/import/cabal.scm (make-cabal-parser): Replace if-then-else grammar case with elif-else, modify if-then accordingly.
(is-elif): New procedure.
(lex-elif): Likewise.
(is-id): Add elif keyword.
(lex-word): Add test for elif.
* tests/hackage.scm (test-cabal-if): New variale.
(test-cabal-else): Likewise.
(test-cabal-elif): Likewise.
(test-cabal-elif-brackets): Likewise.
(match-ghc-elif): Likewise.
("hackage->guix-package test lonely if statement",
"hackage->guix-package test else statement",
"hackage->guix-package test elif statement",
"hackage->guix-package test elif statement with brackets"): New tests.

2 files changed, 136 insertions, 29 deletions

diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index 98d7234098..e1a082a31a 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -149,7 +149,7 @@ to the stack."
            (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB COMMON OCURLY)
            (left: OR)
            (left: PROPERTY AND)
-           (right: ELSE NOT))
+           (right: ELIF ELSE NOT))
    ;; --- rules
    (body        (properties sections)   : (append $1 $2))
    (sections    (sections flags)        : (append $1 $2)
@@ -193,32 +193,32 @@ to the stack."
                 (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 ()))
+                (exprs elif-else)          : (append $1 (list ($2 '(()))))
+                (elif-else)                : (list ($1 '(()))))
+   ;; LALR(1) parsers prefer to be left-recursive, which make if-statements slightly involved.
+   ;; XXX: This technically allows multiple else statements.
+   (elif-else   (elif-else ELIF tests OCURLY exprs CCURLY) : (lambda (y) ($1 (list (append (list 'if $3 $5) y))))
+                (elif-else ELIF tests open exprs close) : (lambda (y) ($1 (list (append (list 'if $3 $5) y))))
+                (elif-else ELSE OCURLY exprs CCURLY) : (lambda (y) ($1 (list $4)))
+                ;; 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.
+                (elif-else ELSE open exprs close) : (lambda (y) ($1 (list $4)))
+                ;; Terminating rule.
+                (if-then) : (lambda (y) (append $1 y)))
+   (if-then     (IF tests OCURLY exprs CCURLY) : (list 'if $2 $4)
+                (IF tests open exprs close)    : (list 'if $2 $4))
    (tests       (TEST OPAREN ID CPAREN)        : `(,$1 ,$3)
                 (TRUE)                         : 'true
                 (FALSE)                        : 'false
@@ -386,6 +386,8 @@ matching a string against the created regexp."
 
 (define is-else (make-rx-matcher "^else" regexp/icase))
 
+(define (is-elif s) (string-ci=? s "elif"))
+
 (define (is-if s) (string-ci=? s "if"))
 
 (define (is-true s) (string-ci=? s "true"))
@@ -402,8 +404,8 @@ matching a string against the created regexp."
 
 (define (is-id s port loc)
   (let ((cabal-reserved-words
-         '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup"
-           "source-repository" "benchmark" "common"))
+         '("if" "else" "elif" "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)
@@ -494,6 +496,8 @@ string with the read characters."
 
 (define (lex-else loc) (make-lexical-token 'ELSE loc #f))
 
+(define (lex-elif loc) (make-lexical-token 'ELIF loc #f))
+
 (define (lex-if loc) (make-lexical-token 'IF loc #f))
 
 (define (lex-true loc) (make-lexical-token 'TRUE loc #t))
@@ -568,6 +572,7 @@ location."
 LOC is the current port location."
   (let* ((w (read-delimited " <>=()\t\n" port 'peek)))
     (cond ((is-if w) (lex-if loc))
+          ((is-elif w) (lex-elif loc))
           ((is-test w port) (lex-test w loc))
           ((is-true w) (lex-true loc))
           ((is-false w) (lex-false loc))
diff --git a/tests/hackage.scm b/tests/hackage.scm
index 189b9af173..38f75b268e 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -309,6 +309,108 @@ executable cabal
 (test-assert "hackage->guix-package test flag executable"
   (eval-test-with-cabal test-cabal-flag-executable match-ghc-foo))
 
+;; Check if-elif-else statements
+(define test-cabal-if
+  "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+library
+  if os(first)
+    Build-depends: ghc-c
+")
+
+(define test-cabal-else
+  "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+library
+  if os(first)
+    Build-depends: ghc-a
+  else
+    Build-depends: ghc-c
+")
+
+(define test-cabal-elif
+  "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+library
+  if os(first)
+    Build-depends: ghc-a
+  elif os(second)
+    Build-depends: ghc-b
+  elif os(guix)
+    Build-depends: ghc-c
+  elif os(third)
+    Build-depends: ghc-d
+  else
+    Build-depends: ghc-e
+")
+
+;; Try the same with different bracket styles
+(define test-cabal-elif-brackets
+  "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+library
+  if os(first) {
+    Build-depends: ghc-a
+  }
+  elif os(second)
+    Build-depends: ghc-b
+  elif os(guix) { Build-depends: ghc-c }
+  elif os(third) {
+    Build-depends: ghc-d }
+  else
+    Build-depends: ghc-e
+")
+
+(define-package-matcher match-ghc-elif
+  ('package
+    ('name "ghc-foo")
+    ('version "1.0.0")
+    ('source
+     ('origin
+       ('method 'url-fetch)
+       ('uri ('hackage-uri "foo" 'version))
+       ('sha256
+        ('base32
+         (? string? hash)))))
+    ('build-system 'haskell-build-system)
+    ('inputs ('list 'ghc-c))
+    ('home-page "http://test.org")
+    ('synopsis (? string?))
+    ('description (? string?))
+    ('license 'license:bsd-3)))
+
+(test-assert "hackage->guix-package test lonely if statement"
+  (eval-test-with-cabal test-cabal-else match-ghc-elif
+                        #:cabal-environment '(("os" . "guix"))))
+
+(test-assert "hackage->guix-package test else statement"
+  (eval-test-with-cabal test-cabal-else match-ghc-elif
+                        #:cabal-environment '(("os" . "guix"))))
+
+(test-assert "hackage->guix-package test elif statement"
+  (eval-test-with-cabal test-cabal-elif match-ghc-elif
+                        #:cabal-environment '(("os" . "guix"))))
+
+(test-assert "hackage->guix-package test elif statement with brackets"
+  (eval-test-with-cabal test-cabal-elif-brackets match-ghc-elif
+                        #:cabal-environment '(("os" . "guix"))))
+
 ;; Check Hackage Cabal revisions.
 (define test-cabal-revision
   "name: foo