[jackhill/guix/guix.git] / guix / build / glib-or-gtk-build-system.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build glib-or-gtk-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            glib-or-gtk-build))

;; Commentary:
;;
;; Builder-side code of the standard glib-or-gtk build procedure.
;;
;; Code:

(define (subdirectory-exists? parent sub-directory)
  (directory-exists? (string-append parent sub-directory)))

(define (directory-included? directory directories-list)
  "Is DIRECTORY included in DIRECTORIES-LIST?"
  (fold (lambda (s p) (or (string-ci=? s directory) p))
        #f directories-list))

;; We do not include $HOME/.guix-profile/gtk-v.0 (v=2 or 3) because we do not
;; want to mix gtk+-2 and gtk+-3 modules.  See
;; https://developer.gnome.org/gtk3/stable/gtk-running.html
(define (gtk-module-directories inputs)
  "Check for the existence of \"libdir/gtk-v.0\" in INPUTS.  Return a list
with all found directories."
  (let* ((version
          (if (string-match "gtk\\+-3"
                            (or (assoc-ref inputs "gtk+")
                                (assoc-ref inputs "source")
                                "gtk+-3")) ; we default to version 3
              "3.0"
              "2.0"))
         (gtk-module
          (lambda (input prev)
            (let* ((in (match input
                         ((_ . dir) dir)
                         (_ "")))
                   (libdir
                    (string-append in "/lib/gtk-" version)))
              (if (and (directory-exists? libdir)
                       (not (directory-included? libdir prev)))
                  (cons libdir prev)
                  prev)))))
    (fold gtk-module '() inputs)))

;; See
;; http://www.freedesktop.org/wiki/DesktopThemeSpec
;; http://freedesktop.org/wiki/Specifications/sound-theme-spec
;; http://freedesktop.org/wiki/Specifications/icon-theme-spec
;;
;; Currently desktop themes are not well supported and do not honor
;; XDG_DATA_DIRS.  One example is evince which only looks for desktop themes
;; in $HOME/.themes (for backward compatibility) and in XDG_DATA_HOME (which
;; defaults to $HOME/.local/share).  One way to handle these applications
;; appears to be by making $HOME/.themes a symlink to
;; $HOME/.guix-profile/share/themes.
(define (data-directories inputs)
  "Check for the existence of \"$datadir/glib-2.0/schemas\" or XDG themes data
in INPUTS.  Return a list with all found directories."
  (define (data-directory input previous)
    (let* ((in (match input
                 ((_ . dir) dir)
                 (_ "")))
           (datadir (string-append in "/share")))
      (if (and (or (subdirectory-exists? datadir "/glib-2.0/schemas")
                   (subdirectory-exists? datadir "/sounds")
                   (subdirectory-exists? datadir "/themes")
                   (subdirectory-exists? datadir "/cursors")
                   (subdirectory-exists? datadir "/wallpapers")
                   (subdirectory-exists? datadir "/icons")
                   (subdirectory-exists? datadir "/mime")) ;shared-mime-info
               (not (directory-included? datadir previous)))
          (cons datadir previous)
          previous)))

  (fold data-directory '() inputs))

;; All GIO modules are expected to be installed in GLib's $libdir/gio/modules
;; directory.  That directory has to include a file called giomodule.cache
;; listing all available modules.  GIO can be made aware of modules in other
;; directories with the help of the environment variable GIO_EXTRA_MODULES.
;; The official GIO documentation states that this environment variable should
;; only be used for testing and not in a production environment.  However, it
;; appears that there is no other way of specifying multiple modules
;; directories (NIXOS also does use this variable). See
;; https://developer.gnome.org/gio/stable/running-gio-apps.html
(define (gio-module-directories inputs)
  "Check for the existence of \"$libdir/gio/modules\" in the INPUTS and
returns a list with all found directories."
  (define (gio-module-directory input previous)
    (let* ((in (match input
                 ((_ . dir) dir)
                 (_ "")))
           (gio-mod-dir (string-append in "/lib/gio/modules")))
      (if (and (directory-exists? gio-mod-dir)
               (not (directory-included? gio-mod-dir previous)))
          (cons gio-mod-dir previous)
          previous)))

  (fold gio-module-directory '() inputs))

(define* (wrap-all-programs #:key inputs outputs
                            (glib-or-gtk-wrap-excluded-outputs '())
                            #:allow-other-keys)
  "Implement phase \"glib-or-gtk-wrap\": look for GSettings schemas and
gtk+-v.0 libraries and create wrappers with suitably set environment variables
if found.

Wrapping is not applied to outputs whose name is listed in
GLIB-OR-GTK-WRAP-EXCLUDED-OUTPUTS.  This is useful when an output is known not
to contain any GLib or GTK+ binaries, and where wrapping would gratuitously
add a dependency of that output on GLib and GTK+."
  (define handle-output
    (match-lambda
     ((output . directory)
      (unless (member output glib-or-gtk-wrap-excluded-outputs)
        (let* ((bindir       (string-append directory "/bin"))
               (libexecdir   (string-append directory "/libexec"))
               (bin-list     (append (find-files bindir ".*")
                                     (find-files libexecdir ".*")))
               (datadirs     (data-directories
                              (alist-cons output directory inputs)))
               (gtk-mod-dirs (gtk-module-directories
                              (alist-cons output directory inputs)))
               (gio-mod-dirs (gio-module-directories
                              (alist-cons output directory inputs)))
               (data-env-var
                (if (not (null? datadirs))
                    `("XDG_DATA_DIRS" ":" prefix ,datadirs)
                    #f))
               (gtk-mod-env-var
                (if (not (null? gtk-mod-dirs))
                    `("GTK_PATH" ":" prefix ,gtk-mod-dirs)
                    #f))
               (gio-mod-env-var 
                (if (not (null? gio-mod-dirs))
                    `("GIO_EXTRA_MODULES" ":" prefix ,gio-mod-dirs)
                    #f)))
          (cond
           ((and data-env-var gtk-mod-env-var gio-mod-env-var)
            (for-each (cut wrap-program <>
                           data-env-var
                           gtk-mod-env-var
                           gio-mod-env-var)
                      bin-list))
           ((and data-env-var gtk-mod-env-var (not gio-mod-env-var))
            (for-each (cut wrap-program <>
                           data-env-var
                           gtk-mod-env-var)
                      bin-list))
           ((and data-env-var (not gtk-mod-env-var) gio-mod-env-var)
            (for-each (cut wrap-program <>
                           data-env-var
                           gio-mod-env-var)
                      bin-list))
           ((and (not data-env-var) gtk-mod-env-var gio-mod-env-var)
            (for-each (cut wrap-program <>
                           gio-mod-env-var
                           gtk-mod-env-var)
                      bin-list))
           ((and data-env-var (not gtk-mod-env-var) (not gio-mod-env-var))
            (for-each (cut wrap-program <>
                           data-env-var)
                      bin-list))
           ((and (not data-env-var) gtk-mod-env-var (not gio-mod-env-var))
            (for-each (cut wrap-program <>
                           gtk-mod-env-var)
                      bin-list))
           ((and (not data-env-var) (not gtk-mod-env-var) gio-mod-env-var)
            (for-each (cut wrap-program <>
                           gio-mod-env-var)
                      bin-list))))))))

  (for-each handle-output outputs)
  #t)

(define* (compile-glib-schemas #:key outputs #:allow-other-keys)
  "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas
if needed."
  (for-each (match-lambda
              ((output . directory)
               (let ((schemasdir (string-append directory
                                                "/share/glib-2.0/schemas")))
                 (when (and (directory-exists? schemasdir)
                            (not (file-exists?
                                  (string-append schemasdir "/gschemas.compiled"))))
                   (invoke "glib-compile-schemas" schemasdir)))))
            outputs)
  #t)

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas)
    (add-after 'install 'glib-or-gtk-wrap wrap-all-programs)))

(define* (glib-or-gtk-build #:key inputs (phases %standard-phases)
                            #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; glib-or-gtk-build-system.scm ends here
Commit	Line	Data
be3425e5 FB	1	;;; GNU Guix --- Functional package management for GNU
be3425e5 FB	2	;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch>
ca79e42e	3	;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
09a8f68b	4	;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
be3425e5 FB	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)
61771a79	26	#:use-module (ice-9 ftw)
be3425e5	27	#:use-module (srfi srfi-1)
4efdabb8	28	#:use-module (srfi srfi-26)
be3425e5 FB	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?"
85dbd3dc	43	(fold (lambda (s p) (or (string-ci=? s directory) p))
be3425e5 FB	44	#f directories-list))
be3425e5 FB	45
61771a79 FB	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
be3425e5 FB	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."
85dbd3dc LC	52	(let* ((version
85dbd3dc LC	53	(if (string-match "gtk\\+-3"
be3425e5 FB	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	(_ "")))
85dbd3dc	64	(libdir
be3425e5 FB	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
61771a79 FB	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
ca79e42e	76	;;
61771a79 FB	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)
be3425e5 FB	87	(let* ((in (match input
	88	((_ . dir) dir)
	89	(_ "")))
	90	(datadir (string-append in "/share")))
61771a79 FB	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")
ca79e42e LC	96	(subdirectory-exists? datadir "/icons")
ca79e42e LC	97	(subdirectory-exists? datadir "/mime")) ;shared-mime-info
be3425e5 FB	98	(not (directory-included? datadir previous)))
	99	(cons datadir previous)
	100	previous)))
	101
61771a79 FB	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))
be3425e5	127
73aa8ddb LC	128	(define* (wrap-all-programs #:key inputs outputs
	129	(glib-or-gtk-wrap-excluded-outputs '())
	130	#:allow-other-keys)
be3425e5 FB	131	"Implement phase \"glib-or-gtk-wrap\": look for GSettings schemas and
be3425e5 FB	132	gtk+-v.0 libraries and create wrappers with suitably set environment variables
73aa8ddb LC	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+."
c8b75695 LC	139	(define handle-output
	140	(match-lambda
	141	((output . directory)
73aa8ddb LC	142	(unless (member output glib-or-gtk-wrap-excluded-outputs)
73aa8ddb LC	143	(let* ((bindir (string-append directory "/bin"))
8b43df2b AW	144	(libexecdir (string-append directory "/libexec"))
	145	(bin-list (append (find-files bindir ".*")
	146	(find-files libexecdir ".*")))
61771a79	147	(datadirs (data-directories
73aa8ddb LC	148	(alist-cons output directory inputs)))
	149	(gtk-mod-dirs (gtk-module-directories
	150	(alist-cons output directory inputs)))
61771a79 FB	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)
73aa8ddb LC	156	#f))
	157	(gtk-mod-env-var
	158	(if (not (null? gtk-mod-dirs))
	159	`("GTK_PATH" ":" prefix ,gtk-mod-dirs)
61771a79 FB	160	#f))
	161	(gio-mod-env-var
	162	(if (not (null? gio-mod-dirs))
	163	`("GIO_EXTRA_MODULES" ":" prefix ,gio-mod-dirs)
73aa8ddb LC	164	#f)))
73aa8ddb LC	165	(cond
61771a79 FB	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)
73aa8ddb	171	bin-list))
61771a79 FB	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)
73aa8ddb	176	bin-list))
61771a79 FB	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)
73aa8ddb	198	bin-list))))))))
be3425e5	199
c8b75695 LC	200	(for-each handle-output outputs)
	201	#t)
	202
	203	(define* (compile-glib-schemas #:key outputs #:allow-other-keys)
be3425e5 FB	204	"Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas
be3425e5 FB	205	if needed."
09a8f68b MW	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)
be3425e5 FB	216
be3425e5 FB	217	(define %standard-phases
f84218ac	218	(modify-phases gnu:%standard-phases
f8503e2b	219	(add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas)
f8503e2b	220	(add-after 'install 'glib-or-gtk-wrap wrap-all-programs)))
be3425e5 FB	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