diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/git-download.scm | 2 | ||||
| -rw-r--r-- | guix/glob.scm | 124 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 15 |
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))))) ;;; |