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 | |
31 | substitute)) | |
32 | ||
33 | \f | |
34 | ;;; | |
35 | ;;; Directories. | |
36 | ;;; | |
c36db98c LC |
37 | |
38 | (define (directory-exists? dir) | |
39 | "Return #t if DIR exists and is a directory." | |
9f55cf8d LC |
40 | (let ((s (stat dir #f))) |
41 | (and s | |
42 | (eq? 'directory (stat:type s))))) | |
c36db98c | 43 | |
b0e0d0e9 LC |
44 | (define-syntax-rule (with-directory-excursion dir body ...) |
45 | "Run BODY with DIR as the process's current directory." | |
46 | (let ((init (getcwd))) | |
47 | (dynamic-wind | |
48 | (lambda () | |
49 | (chdir dir)) | |
50 | (lambda () | |
51 | body ...) | |
52 | (lambda () | |
53 | (chdir init))))) | |
54 | ||
55 | \f | |
56 | ;;; | |
57 | ;;; Search paths. | |
58 | ;;; | |
59 | ||
c36db98c LC |
60 | (define (search-path-as-list sub-directories input-dirs) |
61 | "Return the list of directories among SUB-DIRECTORIES that exist in | |
62 | INPUT-DIRS. Example: | |
63 | ||
64 | (search-path-as-list '(\"share/emacs/site-lisp\" \"share/emacs/24.1\") | |
65 | (list \"/package1\" \"/package2\" \"/package3\")) | |
66 | => (\"/package1/share/emacs/site-lisp\" | |
67 | \"/package3/share/emacs/site-lisp\") | |
68 | ||
69 | " | |
70 | (append-map (lambda (input) | |
71 | (filter-map (lambda (dir) | |
72 | (let ((dir (string-append input "/" | |
73 | dir))) | |
74 | (and (directory-exists? dir) | |
75 | dir))) | |
76 | sub-directories)) | |
77 | input-dirs)) | |
78 | ||
79 | (define (list->search-path-as-string lst separator) | |
80 | (string-join lst separator)) | |
81 | ||
82 | (define* (set-path-environment-variable env-var sub-directories input-dirs | |
83 | #:key (separator ":")) | |
84 | "Look for each of SUB-DIRECTORIES in INPUT-DIRS. Set ENV-VAR to a | |
85 | SEPARATOR-separated path accordingly. Example: | |
86 | ||
87 | (set-path-environment-variable \"PKG_CONFIG\" | |
88 | '(\"lib/pkgconfig\") | |
89 | (list package1 package2)) | |
90 | " | |
91 | (setenv env-var | |
92 | (list->search-path-as-string (search-path-as-list sub-directories | |
93 | input-dirs) | |
94 | separator))) | |
b0e0d0e9 LC |
95 | |
96 | \f | |
97 | ;;; | |
98 | ;;; Phases. | |
99 | ;;; | |
100 | ;;; In (guix build gnu-build-system), there are separate phases (configure, | |
101 | ;;; build, test, install). They are represented as a list of name/procedure | |
102 | ;;; pairs. The following procedures make it easy to change the list of | |
103 | ;;; phases. | |
104 | ;;; | |
105 | ||
106 | (define* (alist-cons-before reference key value alist | |
107 | #:optional (key=? equal?)) | |
108 | "Insert the KEY/VALUE pair before the first occurrence of a pair whose key | |
109 | is REFERENCE in ALIST. Use KEY=? to compare keys." | |
110 | (let-values (((before after) | |
111 | (break (match-lambda | |
112 | ((k . _) | |
113 | (key=? k reference))) | |
114 | alist))) | |
115 | (append before (alist-cons key value after)))) | |
116 | ||
117 | (define* (alist-cons-after reference key value alist | |
118 | #:optional (key=? equal?)) | |
119 | "Insert the KEY/VALUE pair after the first occurrence of a pair whose key | |
120 | is REFERENCE in ALIST. Use KEY=? to compare keys." | |
121 | (let-values (((before after) | |
122 | (break (match-lambda | |
123 | ((k . _) | |
124 | (key=? k reference))) | |
125 | alist))) | |
126 | (match after | |
127 | ((reference after ...) | |
128 | (append before (cons* reference `(,key . ,value) after))) | |
129 | (() | |
130 | (append before `((,key . ,value))))))) | |
131 | ||
132 | (define* (alist-replace key value alist #:optional (key=? equal?)) | |
133 | "Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair. | |
134 | An error is raised when no such pair exists." | |
135 | (let-values (((before after) | |
136 | (break (match-lambda | |
137 | ((k . _) | |
138 | (key=? k key))) | |
139 | alist))) | |
140 | (match after | |
141 | ((_ after ...) | |
142 | (append before (alist-cons key value after)))))) | |
143 | ||
144 | \f | |
145 | ;;; | |
146 | ;;; Text substitution (aka. sed). | |
147 | ;;; | |
148 | ||
149 | (define (substitute file pattern match-proc) | |
150 | "For each line of FILE that matches PATTERN, a regexp, call (MATCH-PROC | |
151 | MATCH OUTPUT-PORT)." | |
152 | (let* ((regexp (if (regexp? pattern) | |
153 | pattern | |
154 | (make-regexp pattern regexp/extended))) | |
155 | (template (string-append file ".XXXXXX")) | |
156 | (out (mkstemp! template))) | |
157 | (with-throw-handler #t | |
158 | (lambda () | |
159 | (call-with-input-file file | |
160 | (lambda (in) | |
161 | (let loop ((line (read-line in))) | |
162 | (if (eof-object? line) | |
163 | #t | |
164 | (begin | |
165 | (cond ((regexp-exec regexp line) | |
166 | => | |
167 | (lambda (m) | |
168 | (match-proc m out))) | |
169 | (else | |
170 | (display line out) | |
171 | (newline out))) | |
172 | (loop (read-line in))))))) | |
8e6ecb14 | 173 | (close out) |
b0e0d0e9 LC |
174 | (rename-file template file)) |
175 | (lambda (key . args) | |
176 | (false-if-exception (delete-file template)))))) | |
177 | ||
178 | ;;; Local Variables: | |
179 | ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1) | |
180 | ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1) | |
181 | ;;; End: |