mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 21:46:35 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

utils: Add 'ensure-keyword-arguments'.

Browse source 
* guix/utils.scm (delkw, ensure-keyword-arguments): New procedures.
* tests/utils.scm ("ensure-keyword-arguments"): New test.
This commit is contained in:
Ludovic Courtès 2016-01-06 22:42:09 +01:00
parent 793a43f409
commit 6071122b71
2 changed files with 50 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
guix/utils.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
@ -52,6 +52,7 @@ (define-module (guix utils)
strip-keyword-arguments strip-keyword-arguments
default-keyword-arguments default-keyword-arguments
substitute-keyword-arguments substitute-keyword-arguments
ensure-keyword-arguments
<location> <location>
location location
@ -453,6 +454,45 @@ (define-syntax substitute-keyword-arguments
(() (()
(reverse before))))))) (reverse before)))))))
(define (delkw kw lst)
"Remove KW and its associated value from LST, a keyword/value list such
as '(#:foo 1 #:bar 2)."
(let loop ((lst lst)
(result '()))
(match lst
(()
(reverse result))
((kw? value rest ...)
(if (eq? kw? kw)
(append (reverse result) rest)
(loop rest (cons* value kw? result)))))))
(define (ensure-keyword-arguments args kw/values)
"Force the keywords arguments KW/VALUES in the keyword argument list ARGS.
For instance:
(ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
=> (#:foo 2)
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
=> (#:foo 2 #:bar 3)
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))
=> (#:foo 42 #:bar 3)
"
(let loop ((args args)
(kw/values kw/values)
(result '()))
(match args
(()
(append (reverse result) kw/values))
((kw value rest ...)
(match (memq kw kw/values)
((_ value . _)
(loop rest (delkw kw kw/values) (cons* value kw result)))
(#f
(loop rest kw/values (cons* value kw result))))))))
(define* (nix-system->gnu-triplet (define* (nix-system->gnu-triplet
#:optional (system (%current-system)) (vendor "unknown")) #:optional (system (%current-system)) (vendor "unknown"))
"Return a guess of the GNU triplet corresponding to Nix system "Return a guess of the GNU triplet corresponding to Nix system

10
tests/utils.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -141,6 +141,14 @@ (define temp-file
'(a #:foo 42 #:b b #:baz 3 '(a #:foo 42 #:b b #:baz 3
#:c c #:bar 4))) #:c c #:bar 4)))
(test-equal "ensure-keyword-arguments"
'((#:foo 2)
(#:foo 2 #:bar 3)
(#:foo 42 #:bar 3))
(list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
(let* ((tree (alist->vhash (let* ((tree (alist->vhash
'((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6)) '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
hashq)) hashq))