import: hackage: Parse braced properties.

This adds partial support for Cabal properties that use curly
braces instead of the layout rule.  See for example
https://hackage.haskell.org/package/cassava/

* guix/import/cabal.scm (read-braced-value): New procedure.
(is-property): Remove.
(is-layout-property, is-braced-property): New variables.
(lex-property): Rename to...
(lex-layout-property): ... this.
(lex-braced-property, lex-property): New procedures.
(lex-token): Add call to 'lex-property'.
* guix/tests/hackage.scm: Test braced description import.
* tests/hackage.scm (test-cabal-multiline-desc): Rename to...
(test-cabal-multiline-layout): ... this.
("hackage->guix-package test multiline desc"): Rename to...
("hackage->guix-package test multiline desc (layout)"): ... this.
(test-cabal-multiline-braced): New variable.
("hackage->guix-package test multiline desc (braced)"): New test.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Robert Vollmert 2019-06-02 00:27:50 +02:00 committed by Ludovic Courtès
parent 64d3181357
commit 959c9d159d
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 50 additions and 10 deletions

View File

@ -270,6 +270,10 @@ following lines with indentation larger than MIN-INDENT."
(peek-next-line-indent port))) (peek-next-line-indent port)))
val))) 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) (define (lex-white-space port bol)
"Consume white spaces and comment lines on PORT. If a new line is started return #t, "Consume white spaces and comment lines on PORT. If a new line is started return #t,
otherwise return BOL (beginning-of-line)." otherwise return BOL (beginning-of-line)."
@ -343,8 +347,11 @@ matching a string against the created regexp."
(make-regexp pat)))) (make-regexp pat))))
(cut regexp-exec rx <>))) (cut regexp-exec rx <>)))
(define is-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?.*)$" (define is-layout-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?[^{}]*)$"
regexp/icase)) 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_-]+)" (define is-flag (make-rx-matcher "^flag +([a-z0-9_-]+)"
regexp/icase)) regexp/icase))
@ -435,13 +442,19 @@ string with the read characters."
(begin (unread-char c) (list->string res))))) (begin (unread-char c) (list->string res)))))
(else (list->string res))))) (else (list->string res)))))
(define (lex-property k-v-rx-res loc port) (define (lex-layout-property k-v-rx-res loc port)
(let ((key (string-downcase (match:substring k-v-rx-res 1))) (let ((key (string-downcase (match:substring k-v-rx-res 1)))
(value (match:substring k-v-rx-res 2))) (value (match:substring k-v-rx-res 2)))
(make-lexical-token (make-lexical-token
'PROPERTY loc 'PROPERTY loc
(list key `(,(read-value port value (current-indentation))))))) (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) (define (lex-rx-res rx-res token loc)
(let ((name (string-downcase (match:substring rx-res 1)))) (let ((name (string-downcase (match:substring rx-res 1))))
(make-lexical-token token loc name))) (make-lexical-token token loc name)))
@ -552,7 +565,6 @@ LOC is the current port location."
the current port location." the current port location."
(let* ((s (read-delimited "\n{}" port 'peek))) (let* ((s (read-delimited "\n{}" port 'peek)))
(cond (cond
((is-property s) => (cut lex-property <> loc port))
((is-flag s) => (cut lex-flag <> loc)) ((is-flag s) => (cut lex-flag <> loc))
((is-src-repo s) => (cut lex-src-repo <> loc)) ((is-src-repo s) => (cut lex-src-repo <> loc))
((is-exec s) => (cut lex-exec <> loc)) ((is-exec s) => (cut lex-exec <> loc))
@ -561,13 +573,22 @@ the current port location."
((is-benchmark s) => (cut lex-benchmark <> loc)) ((is-benchmark s) => (cut lex-benchmark <> loc))
((is-lib s) (lex-lib loc)) ((is-lib s) (lex-lib loc))
((is-else s) (lex-else loc)) ((is-else s) (lex-else loc))
(else (else (unread-string s port) #f))))
#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) (define (lex-token port)
(let* ((loc (make-source-location (cabal-file-name) (port-line port) (let* ((loc (make-source-location (cabal-file-name) (port-line port)
(port-column port) -1 -1))) (port-column port) -1 -1)))
(or (lex-single-char port loc) (lex-word port loc) (lex-line port loc)))) (or (lex-single-char port loc)
(lex-word port loc)
(lex-line port loc)
(lex-property port loc))))
;; Lexer- and error-function generators ;; Lexer- and error-function generators

View File

@ -237,7 +237,7 @@ library
(eval-test-with-cabal test-cabal-6 match-ghc-foo-6)) (eval-test-with-cabal test-cabal-6 match-ghc-foo-6))
;; Check multi-line layouted description ;; Check multi-line layouted description
(define test-cabal-multiline-desc (define test-cabal-multiline-layout
"name: foo "name: foo
version: 1.0.0 version: 1.0.0
homepage: http://test.org homepage: http://test.org
@ -251,9 +251,28 @@ executable cabal
mtl >= 2.0 && < 3 mtl >= 2.0 && < 3
") ")
(test-assert "hackage->guix-package test multiline desc" (test-assert "hackage->guix-package test multiline desc (layout)"
(eval-test-with-cabal test-cabal-multiline-desc match-ghc-foo)) (eval-test-with-cabal test-cabal-multiline-layout match-ghc-foo))
;; Check multi-line braced description
(define test-cabal-multiline-braced
"name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: {
first line
second line
}
license: BSD3
executable cabal
build-depends:
HTTP >= 4000.2.5 && < 4000.3,
mtl >= 2.0 && < 3
")
(test-assert "hackage->guix-package test multiline desc (braced)"
(eval-test-with-cabal test-cabal-multiline-braced match-ghc-foo))
(test-assert "read-cabal test 1" (test-assert "read-cabal test 1"
(match (call-with-input-string test-read-cabal-1 read-cabal) (match (call-with-input-string test-read-cabal-1 read-cabal)