guix/build/glib-or-gtk-build-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch>
   3 ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix build glib-or-gtk-build-system)
  22   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  23   #:use-module (guix build utils)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 regex)
  26   #:use-module (ice-9 ftw)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-26)
  29   #:export (%standard-phases
  30             glib-or-gtk-build))
  31
  32 ;; Commentary:
  33 ;;
  34 ;; Builder-side code of the standard glib-or-gtk build procedure.
  35 ;;
  36 ;; Code:
  37
  38 (define (subdirectory-exists? parent sub-directory)
  39   (directory-exists? (string-append parent sub-directory)))
  40
  41 (define (directory-included? directory directories-list)
  42   "Is DIRECTORY included in DIRECTORIES-LIST?"
  43   (fold (lambda (s p) (or (string-ci=? s directory) p))
  44         #f directories-list))
  45
  46 ;; We do not include $HOME/.guix-profile/gtk-v.0 (v=2 or 3) because we do not
  47 ;; want to mix gtk+-2 and gtk+-3 modules.  See
  48 ;; https://developer.gnome.org/gtk3/stable/gtk-running.html
  49 (define (gtk-module-directories inputs)
  50   "Check for the existence of \"libdir/gtk-v.0\" in INPUTS.  Return a list
  51 with all found directories."
  52   (let* ((version
  53           (if (string-match "gtk\\+-3"
  54                             (or (assoc-ref inputs "gtk+")
  55                                 (assoc-ref inputs "source")
  56                                 "gtk+-3")) ; we default to version 3
  57               "3.0"
  58               "2.0"))
  59          (gtk-module
  60           (lambda (input prev)
  61             (let* ((in (match input
  62                          ((_ . dir) dir)
  63                          (_ "")))
  64                    (libdir
  65                     (string-append in "/lib/gtk-" version)))
  66               (if (and (directory-exists? libdir)
  67                        (not (directory-included? libdir prev)))
  68                   (cons libdir prev)
  69                   prev)))))
  70     (fold gtk-module '() inputs)))
  71
  72 ;; See
  73 ;; http://www.freedesktop.org/wiki/DesktopThemeSpec
  74 ;; http://freedesktop.org/wiki/Specifications/sound-theme-spec
  75 ;; http://freedesktop.org/wiki/Specifications/icon-theme-spec
  76 ;;
  77 ;; Currently desktop themes are not well supported and do not honor
  78 ;; XDG_DATA_DIRS.  One example is evince which only looks for desktop themes
  79 ;; in $HOME/.themes (for backward compatibility) and in XDG_DATA_HOME (which
  80 ;; defaults to $HOME/.local/share).  One way to handle these applications
  81 ;; appears to be by making $HOME/.themes a symlink to
  82 ;; $HOME/.guix-profile/share/themes.
  83 (define (data-directories inputs)
  84   "Check for the existence of \"$datadir/glib-2.0/schemas\" or XDG themes data
  85 in INPUTS.  Return a list with all found directories."
  86   (define (data-directory input previous)
  87     (let* ((in (match input
  88                  ((_ . dir) dir)
  89                  (_ "")))
  90            (datadir (string-append in "/share")))
  91       (if (and (or (subdirectory-exists? datadir "/glib-2.0/schemas")
  92                    (subdirectory-exists? datadir "/sounds")
  93                    (subdirectory-exists? datadir "/themes")
  94                    (subdirectory-exists? datadir "/cursors")
  95                    (subdirectory-exists? datadir "/wallpapers")
  96                    (subdirectory-exists? datadir "/icons")
  97                    (subdirectory-exists? datadir "/mime")) ;shared-mime-info
  98                (not (directory-included? datadir previous)))
  99           (cons datadir previous)
 100           previous)))
 101
 102   (fold data-directory '() inputs))
 103
 104 ;; All GIO modules are expected to be installed in GLib's $libdir/gio/modules
 105 ;; directory.  That directory has to include a file called giomodule.cache
 106 ;; listing all available modules.  GIO can be made aware of modules in other
 107 ;; directories with the help of the environment variable GIO_EXTRA_MODULES.
 108 ;; The official GIO documentation states that this environment variable should
 109 ;; only be used for testing and not in a production environment.  However, it
 110 ;; appears that there is no other way of specifying multiple modules
 111 ;; directories (NIXOS also does use this variable). See
 112 ;; https://developer.gnome.org/gio/stable/running-gio-apps.html
 113 (define (gio-module-directories inputs)
 114   "Check for the existence of \"$libdir/gio/modules\" in the INPUTS and
 115 returns a list with all found directories."
 116   (define (gio-module-directory input previous)
 117     (let* ((in (match input
 118                  ((_ . dir) dir)
 119                  (_ "")))
 120            (gio-mod-dir (string-append in "/lib/gio/modules")))
 121       (if (and (directory-exists? gio-mod-dir)
 122                (not (directory-included? gio-mod-dir previous)))
 123           (cons gio-mod-dir previous)
 124           previous)))
 125
 126   (fold gio-module-directory '() inputs))
 127
 128 (define* (wrap-all-programs #:key inputs outputs
 129                             (glib-or-gtk-wrap-excluded-outputs '())
 130                             #:allow-other-keys)
 131   "Implement phase \"glib-or-gtk-wrap\": look for GSettings schemas and
 132 gtk+-v.0 libraries and create wrappers with suitably set environment variables
 133 if found.
 134
 135 Wrapping is not applied to outputs whose name is listed in
 136 GLIB-OR-GTK-WRAP-EXCLUDED-OUTPUTS.  This is useful when an output is known not
 137 to contain any GLib or GTK+ binaries, and where wrapping would gratuitously
 138 add a dependency of that output on GLib and GTK+."
 139   (define handle-output
 140     (match-lambda
 141      ((output . directory)
 142       (unless (member output glib-or-gtk-wrap-excluded-outputs)
 143         (let* ((bindir       (string-append directory "/bin"))
 144                (libexecdir   (string-append directory "/libexec"))
 145                (bin-list     (append (find-files bindir ".*")
 146                                      (find-files libexecdir ".*")))
 147                (datadirs     (data-directories
 148                               (alist-cons output directory inputs)))
 149                (gtk-mod-dirs (gtk-module-directories
 150                               (alist-cons output directory inputs)))
 151                (gio-mod-dirs (gio-module-directories
 152                               (alist-cons output directory inputs)))
 153                (data-env-var
 154                 (if (not (null? datadirs))
 155                     `("XDG_DATA_DIRS" ":" prefix ,datadirs)
 156                     #f))
 157                (gtk-mod-env-var
 158                 (if (not (null? gtk-mod-dirs))
 159                     `("GTK_PATH" ":" prefix ,gtk-mod-dirs)
 160                     #f))
 161                (gio-mod-env-var
 162                 (if (not (null? gio-mod-dirs))
 163                     `("GIO_EXTRA_MODULES" ":" prefix ,gio-mod-dirs)
 164                     #f)))
 165           (cond
 166            ((and data-env-var gtk-mod-env-var gio-mod-env-var)
 167             (for-each (cut wrap-program <>
 168                            data-env-var
 169                            gtk-mod-env-var
 170                            gio-mod-env-var)
 171                       bin-list))
 172            ((and data-env-var gtk-mod-env-var (not gio-mod-env-var))
 173             (for-each (cut wrap-program <>
 174                            data-env-var
 175                            gtk-mod-env-var)
 176                       bin-list))
 177            ((and data-env-var (not gtk-mod-env-var) gio-mod-env-var)
 178             (for-each (cut wrap-program <>
 179                            data-env-var
 180                            gio-mod-env-var)
 181                       bin-list))
 182            ((and (not data-env-var) gtk-mod-env-var gio-mod-env-var)
 183             (for-each (cut wrap-program <>
 184                            gio-mod-env-var
 185                            gtk-mod-env-var)
 186                       bin-list))
 187            ((and data-env-var (not gtk-mod-env-var) (not gio-mod-env-var))
 188             (for-each (cut wrap-program <>
 189                            data-env-var)
 190                       bin-list))
 191            ((and (not data-env-var) gtk-mod-env-var (not gio-mod-env-var))
 192             (for-each (cut wrap-program <>
 193                            gtk-mod-env-var)
 194                       bin-list))
 195            ((and (not data-env-var) (not gtk-mod-env-var) gio-mod-env-var)
 196             (for-each (cut wrap-program <>
 197                            gio-mod-env-var)
 198                       bin-list))))))))
 199
 200   (for-each handle-output outputs)
 201   #t)
 202
 203 (define* (compile-glib-schemas #:key outputs #:allow-other-keys)
 204   "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas
 205 if needed."
 206   (for-each (match-lambda
 207               ((output . directory)
 208                (let ((schemasdir (string-append directory
 209                                                 "/share/glib-2.0/schemas")))
 210                  (when (and (directory-exists? schemasdir)
 211                             (not (file-exists?
 212                                   (string-append schemasdir "/gschemas.compiled"))))
 213                    (invoke "glib-compile-schemas" schemasdir)))))
 214             outputs)
 215   #t)
 216
 217 (define %standard-phases
 218   (modify-phases gnu:%standard-phases
 219     (add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas)
 220     (add-after 'install 'glib-or-gtk-wrap wrap-all-programs)))
 221
 222 (define* (glib-or-gtk-build #:key inputs (phases %standard-phases)
 223                             #:allow-other-keys #:rest args)
 224   "Build the given package, applying all of PHASES in order."
 225   (apply gnu:gnu-build #:inputs inputs #:phases phases args))
 226
 227 ;;; glib-or-gtk-build-system.scm ends here