1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Guix.
;;;
;;; Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:export (directory-exists?
with-directory-excursion
set-path-environment-variable
alist-cons-before
alist-cons-after
alist-replace
substitute))
;;;
;;; Directories.
;;;
(define (directory-exists? dir)
"Return #t if DIR exists and is a directory."
(let ((s (stat dir #f)))
(and s
(eq? 'directory (stat:type s)))))
(define-syntax-rule (with-directory-excursion dir body ...)
"Run BODY with DIR as the process's current directory."
(let ((init (getcwd)))
(dynamic-wind
(lambda ()
(chdir dir))
(lambda ()
body ...)
(lambda ()
(chdir init)))))
;;;
;;; Search paths.
;;;
(define (search-path-as-list sub-directories input-dirs)
"Return the list of directories among SUB-DIRECTORIES that exist in
INPUT-DIRS. Example:
(search-path-as-list '(\"share/emacs/site-lisp\" \"share/emacs/24.1\")
(list \"/package1\" \"/package2\" \"/package3\"))
=> (\"/package1/share/emacs/site-lisp\"
\"/package3/share/emacs/site-lisp\")
"
(append-map (lambda (input)
(filter-map (lambda (dir)
(let ((dir (string-append input "/"
dir)))
(and (directory-exists? dir)
dir)))
sub-directories))
input-dirs))
(define (list->search-path-as-string lst separator)
(string-join lst separator))
(define* (set-path-environment-variable env-var sub-directories input-dirs
#:key (separator ":"))
"Look for each of SUB-DIRECTORIES in INPUT-DIRS. Set ENV-VAR to a
SEPARATOR-separated path accordingly. Example:
(set-path-environment-variable \"PKG_CONFIG\"
'(\"lib/pkgconfig\")
(list package1 package2))
"
(setenv env-var
(list->search-path-as-string (search-path-as-list sub-directories
input-dirs)
separator)))
;;;
;;; Phases.
;;;
;;; In (guix build gnu-build-system), there are separate phases (configure,
;;; build, test, install). They are represented as a list of name/procedure
;;; pairs. The following procedures make it easy to change the list of
;;; phases.
;;;
(define* (alist-cons-before reference key value alist
#:optional (key=? equal?))
"Insert the KEY/VALUE pair before the first occurrence of a pair whose key
is REFERENCE in ALIST. Use KEY=? to compare keys."
(let-values (((before after)
(break (match-lambda
((k . _)
(key=? k reference)))
alist)))
(append before (alist-cons key value after))))
(define* (alist-cons-after reference key value alist
#:optional (key=? equal?))
"Insert the KEY/VALUE pair after the first occurrence of a pair whose key
is REFERENCE in ALIST. Use KEY=? to compare keys."
(let-values (((before after)
(break (match-lambda
((k . _)
(key=? k reference)))
alist)))
(match after
((reference after ...)
(append before (cons* reference `(,key . ,value) after)))
(()
(append before `((,key . ,value)))))))
(define* (alist-replace key value alist #:optional (key=? equal?))
"Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair.
An error is raised when no such pair exists."
(let-values (((before after)
(break (match-lambda
((k . _)
(key=? k key)))
alist)))
(match after
((_ after ...)
(append before (alist-cons key value after))))))
;;;
;;; Text substitution (aka. sed).
;;;
(define (substitute file pattern match-proc)
"For each line of FILE that matches PATTERN, a regexp, call (MATCH-PROC
MATCH OUTPUT-PORT)."
(let* ((regexp (if (regexp? pattern)
pattern
(make-regexp pattern regexp/extended)))
(template (string-append file ".XXXXXX"))
(out (mkstemp! template)))
(with-throw-handler #t
(lambda ()
(call-with-input-file file
(lambda (in)
(let loop ((line (read-line in)))
(if (eof-object? line)
#t
(begin
(cond ((regexp-exec regexp line)
=>
(lambda (m)
(match-proc m out)))
(else
(display line out)
(newline out)))
(loop (read-line in)))))))
(close out)
(rename-file template file))
(lambda (key . args)
(false-if-exception (delete-file template))))))
;;; Local Variables:
;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
;;; End:
|
