Commit | Line | Data |
---|---|---|
be3425e5 FB |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU 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 | ;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix build glib-or-gtk-build-system) | |
20 | #:use-module ((guix build gnu-build-system) #:prefix gnu:) | |
21 | #:use-module (guix build utils) | |
22 | #:use-module (ice-9 match) | |
23 | #:use-module (ice-9 regex) | |
24 | #:use-module (srfi srfi-1) | |
25 | #:export (%standard-phases | |
26 | glib-or-gtk-build)) | |
27 | ||
28 | ;; Commentary: | |
29 | ;; | |
30 | ;; Builder-side code of the standard glib-or-gtk build procedure. | |
31 | ;; | |
32 | ;; Code: | |
33 | ||
34 | (define (subdirectory-exists? parent sub-directory) | |
35 | (directory-exists? (string-append parent sub-directory))) | |
36 | ||
37 | (define (directory-included? directory directories-list) | |
38 | "Is DIRECTORY included in DIRECTORIES-LIST?" | |
39 | (fold (lambda (s p) (or (string-ci=? s directory) p)) | |
40 | #f directories-list)) | |
41 | ||
42 | (define (gtk-module-directories inputs) | |
43 | "Check for the existence of \"libdir/gtk-v.0\" in INPUTS. Return a list | |
44 | with all found directories." | |
45 | (let* ((version | |
46 | (if (string-match "gtk\\+-3" | |
47 | (or (assoc-ref inputs "gtk+") | |
48 | (assoc-ref inputs "source") | |
49 | "gtk+-3")) ; we default to version 3 | |
50 | "3.0" | |
51 | "2.0")) | |
52 | (gtk-module | |
53 | (lambda (input prev) | |
54 | (let* ((in (match input | |
55 | ((_ . dir) dir) | |
56 | (_ ""))) | |
57 | (libdir | |
58 | (string-append in "/lib/gtk-" version))) | |
59 | (if (and (directory-exists? libdir) | |
60 | (not (directory-included? libdir prev))) | |
61 | (cons libdir prev) | |
62 | prev))))) | |
63 | (fold gtk-module '() inputs))) | |
64 | ||
65 | (define (schemas-directories inputs) | |
66 | "Check for the existence of \"datadir/glib-2.0/schemas\" in INPUTS. Return | |
67 | a list with all found directories." | |
68 | (define (glib-schemas input previous) | |
69 | (let* ((in (match input | |
70 | ((_ . dir) dir) | |
71 | (_ ""))) | |
72 | (datadir (string-append in "/share"))) | |
73 | (if (and (subdirectory-exists? datadir "/glib-2.0/schemas") | |
74 | (not (directory-included? datadir previous))) | |
75 | (cons datadir previous) | |
76 | previous))) | |
77 | ||
78 | (fold glib-schemas '() inputs)) | |
79 | ||
80 | (define* (wrap-all-programs #:key inputs outputs #:allow-other-keys) | |
81 | "Implement phase \"glib-or-gtk-wrap\": look for GSettings schemas and | |
82 | gtk+-v.0 libraries and create wrappers with suitably set environment variables | |
83 | if found." | |
84 | (let* ((out (assoc-ref outputs "out")) | |
85 | (bindir (string-append out "/bin")) | |
86 | (bin-list (find-files bindir ".*")) | |
87 | (schemas (schemas-directories (acons "out" out inputs))) | |
88 | (schemas-env-var | |
89 | (if (not (null? schemas)) | |
90 | `("XDG_DATA_DIRS" ":" prefix ,schemas) | |
91 | #f)) | |
92 | (gtk-mod-dirs (gtk-module-directories (acons "out" out inputs))) | |
93 | (gtk-mod-env-var | |
94 | (if (not (null? gtk-mod-dirs)) | |
95 | `("GTK_PATH" ":" prefix ,gtk-mod-dirs) | |
96 | #f))) | |
97 | (cond | |
98 | ((and schemas-env-var gtk-mod-env-var) | |
99 | (map (lambda (prog) | |
100 | (wrap-program prog schemas-env-var gtk-mod-env-var)) | |
101 | bin-list)) | |
102 | (schemas-env-var | |
103 | (map (lambda (prog) (wrap-program prog schemas-env-var)) bin-list)) | |
104 | (gtk-mod-env-var | |
105 | (map (lambda (prog) (wrap-program prog gtk-mod-env-var)) bin-list))))) | |
106 | ||
107 | (define* (compile-glib-schemas #:key inputs outputs #:allow-other-keys) | |
108 | "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas | |
109 | if needed." | |
110 | (let* ((out (assoc-ref outputs "out")) | |
111 | (schemasdir (string-append out "/share/glib-2.0/schemas"))) | |
112 | (if (and (directory-exists? schemasdir) | |
113 | (not (file-exists? | |
114 | (string-append schemasdir "/gschemas.compiled")))) | |
115 | (system* "glib-compile-schemas" schemasdir) | |
116 | #t))) | |
117 | ||
118 | (define %standard-phases | |
119 | (alist-cons-after | |
120 | 'install 'glib-or-gtk-wrap wrap-all-programs | |
121 | (alist-cons-after | |
122 | 'install 'glib-or-gtk-compile-schemas compile-glib-schemas | |
123 | gnu:%standard-phases))) | |
124 | ||
125 | (define* (glib-or-gtk-build #:key inputs (phases %standard-phases) | |
126 | #:allow-other-keys #:rest args) | |
127 | "Build the given package, applying all of PHASES in order." | |
128 | (apply gnu:gnu-build #:inputs inputs #:phases phases args)) | |
129 | ||
130 | ;;; glib-or-gtk-build-system.scm ends here |