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