summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/git-download.scm2
-rw-r--r--guix/glob.scm124
-rw-r--r--guix/import/elpa.scm15
3 files changed, 93 insertions, 48 deletions
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 731e549b38..33f102bc6c 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -109,7 +109,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
;; grep, etc. to be in $PATH.
(set-path-environment-variable "PATH" '("bin")
(match '#+inputs
- (((names dirs) ...)
+ (((names dirs outputs ...) ...)
dirs)))
(or (git-fetch (getenv "git url") (getenv "git commit")
diff --git a/guix/glob.scm b/guix/glob.scm
index 4fc5173ac0..a9fc744802 100644
--- a/guix/glob.scm
+++ b/guix/glob.scm
@@ -18,80 +18,120 @@
(define-module (guix glob)
#:use-module (ice-9 match)
- #:export (compile-glob-pattern
+ #:export (string->sglob
+ compile-sglob
+ string->compiled-sglob
glob-match?))
;;; Commentary:
;;;
;;; This is a minimal implementation of "glob patterns" (info "(libc)
;;; Globbbing"). It is currently limited to simple patterns and does not
-;;; support braces and square brackets, for instance.
+;;; support braces, for instance.
;;;
;;; Code:
-(define (wildcard-indices str)
- "Return the list of indices in STR where wildcards can be found."
- (let loop ((index 0)
- (result '()))
- (if (= index (string-length str))
- (reverse result)
- (loop (+ 1 index)
- (case (string-ref str index)
- ((#\? #\*) (cons index result))
- (else result))))))
+(define (parse-bracket chars)
+ "Parse CHARS, a list of characters that extracted from a '[...]' sequence."
+ (match chars
+ ((start #\- end)
+ `(range ,start ,end))
+ (lst
+ `(set ,@lst))))
-(define (compile-glob-pattern str)
- "Return an sexp that represents the compiled form of STR, a glob pattern
-such as \"foo*\" or \"foo??bar\"."
+(define (string->sglob str)
+ "Return an sexp, called an \"sglob\", that represents the compiled form of
+STR, a glob pattern such as \"foo*\" or \"foo??bar\"."
(define flatten
(match-lambda
(((? string? str)) str)
(x x)))
- (let loop ((index 0)
- (indices (wildcard-indices str))
+ (define (cons-string chars lst)
+ (match chars
+ (() lst)
+ (_ (cons (list->string (reverse chars)) lst))))
+
+ (let loop ((chars (string->list str))
+ (pending '())
+ (brackets 0)
(result '()))
- (match indices
+ (match chars
(()
- (flatten (cond ((zero? index)
- (list str))
- ((= index (string-length str))
- (reverse result))
- (else
- (reverse (cons (string-drop str index)
- result))))))
- ((wildcard-index . rest)
- (let ((wildcard (match (string-ref str wildcard-index)
+ (flatten (reverse (if (null? pending)
+ result
+ (cons-string pending result)))))
+ (((and chr (or #\? #\*)) . rest)
+ (let ((wildcard (match chr
(#\? '?)
(#\* '*))))
- (match (substring str index wildcard-index)
- ("" (loop (+ 1 wildcard-index)
- rest
- (cons wildcard result)))
- (str (loop (+ 1 wildcard-index)
- rest
- (cons* wildcard str result)))))))))
+ (if (zero? brackets)
+ (loop rest '() 0
+ (cons* wildcard (cons-string pending result)))
+ (loop rest (cons chr pending) brackets result))))
+ ((#\[ . rest)
+ (if (zero? brackets)
+ (loop rest '() (+ 1 brackets)
+ (cons-string pending result))
+ (loop rest (cons #\[ pending) (+ 1 brackets) result)))
+ ((#\] . rest)
+ (cond ((zero? brackets)
+ (error "unexpected closing bracket" str))
+ ((= 1 brackets)
+ (loop rest '() 0
+ (cons (parse-bracket (reverse pending)) result)))
+ (else
+ (loop rest (cons #\] pending) (- brackets 1) result))))
+ ((chr . rest)
+ (loop rest (cons chr pending) brackets result)))))
+
+(define (compile-sglob sglob)
+ "Compile SGLOB into a more efficient representation."
+ (if (string? sglob)
+ sglob
+ (let loop ((sglob sglob)
+ (result '()))
+ (match sglob
+ (()
+ (reverse result))
+ (('? . rest)
+ (loop rest (cons char-set:full result)))
+ ((('range start end) . rest)
+ (loop rest (cons (ucs-range->char-set
+ (char->integer start)
+ (+ 1 (char->integer end)))
+ result)))
+ ((('set . chars) . rest)
+ (loop rest (cons (list->char-set chars) result)))
+ ((head . rest)
+ (loop rest (cons head result)))))))
+
+(define string->compiled-sglob
+ (compose compile-sglob string->sglob))
(define (glob-match? pattern str)
"Return true if STR matches PATTERN, a compiled glob pattern as returned by
-'compile-glob-pattern'."
+'compile-sglob'."
(let loop ((pattern pattern)
(str str))
(match pattern
- ((? string? literal) (string=? literal str))
- (((? string? one)) (string=? one str))
- (('*) #t)
- (('?) (= 1 (string-length str)))
- (() #t)
+ ((? string? literal)
+ (string=? literal str))
+ (()
+ (string-null? str))
+ (('*)
+ #t)
(('* suffix . rest)
(match (string-contains str suffix)
(#f #f)
(index (loop rest
(string-drop str
(+ index (string-length suffix)))))))
- (('? . rest)
+ (((? char-set? cs) . rest)
(and (>= (string-length str) 1)
- (loop rest (string-drop str 1))))
+ (let ((chr (string-ref str 0)))
+ (and (char-set-contains? cs chr)
+ (loop rest (string-drop str 1))))))
((prefix . rest)
(and (string-prefix? prefix str)
(loop rest (string-drop str (string-length prefix))))))))
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 5d3d04ee7c..43e9eb60c9 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -190,7 +190,7 @@ include VERSION."
url)))
(_ #f))))
-(define* (elpa-package->sexp pkg)
+(define* (elpa-package->sexp pkg #:optional license)
"Return the `package' S-expression for the Emacs package PKG, a record of
type '<elpa-package>'."
@@ -234,12 +234,17 @@ type '<elpa-package>'."
(home-page ,(elpa-package-home-page pkg))
(synopsis ,(elpa-package-synopsis pkg))
(description ,(elpa-package-description pkg))
- (license license:gpl3+))))
+ (license ,license))))
(define* (elpa->guix-package name #:optional (repo 'gnu))
"Fetch the package NAME from REPO and produce a Guix package S-expression."
- (let ((pkg (fetch-elpa-package name repo)))
- (and=> pkg elpa-package->sexp)))
+ (match (fetch-elpa-package name repo)
+ (#f #f)
+ (package
+ ;; ELPA is known to contain only GPLv3+ code. Other repos may contain
+ ;; code under other license but there's no license metadata.
+ (let ((license (and (eq? 'gnu repo) 'license:gpl3+)))
+ (elpa-package->sexp package license)))))
;;;