profiles: Build GTK+ input module cache.
* guix/profiles.scm (gtk-im-modules): New procedure. (%default-profile-hooks): Add it.
This commit is contained in:
		
							parent
							
								
									2c9f4786c9
								
							
						
					
					
						commit
						7ddc178093
					
				
					 1 changed files with 62 additions and 0 deletions
				
			
		| 
						 | 
				
			
			@ -4,6 +4,7 @@
 | 
			
		|||
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
 | 
			
		||||
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 | 
			
		||||
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 | 
			
		||||
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 | 
			
		||||
;;;
 | 
			
		||||
;;; This file is part of GNU Guix.
 | 
			
		||||
;;;
 | 
			
		||||
| 
						 | 
				
			
			@ -723,6 +724,66 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
 | 
			
		|||
                          #:substitutable? #f)
 | 
			
		||||
        (return #f))))
 | 
			
		||||
 | 
			
		||||
(define (gtk-im-modules manifest)
 | 
			
		||||
  "Return a derivation that builds the cache files for input method modules
 | 
			
		||||
for both major versions of GTK+."
 | 
			
		||||
 | 
			
		||||
  (mlet %store-monad ((gtk+   (manifest-lookup-package manifest "gtk+" "3"))
 | 
			
		||||
                      (gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
 | 
			
		||||
 | 
			
		||||
    (define (build gtk gtk-version)
 | 
			
		||||
      (let ((major (string-take gtk-version 1)))
 | 
			
		||||
        (with-imported-modules '((guix build utils)
 | 
			
		||||
                                 (guix build union)
 | 
			
		||||
                                 (guix build profiles)
 | 
			
		||||
                                 (guix search-paths)
 | 
			
		||||
                                 (guix records))
 | 
			
		||||
          #~(begin
 | 
			
		||||
              (use-modules (guix build utils)
 | 
			
		||||
                           (guix build union)
 | 
			
		||||
                           (guix build profiles)
 | 
			
		||||
                           (ice-9 popen)
 | 
			
		||||
                           (srfi srfi-1)
 | 
			
		||||
                           (srfi srfi-26))
 | 
			
		||||
 | 
			
		||||
              (let* ((prefix  (string-append "/lib/gtk-" #$major ".0/"
 | 
			
		||||
                                             #$gtk-version))
 | 
			
		||||
                     (query   (string-append #$gtk "/bin/gtk-query-immodules-"
 | 
			
		||||
                                             #$major ".0"))
 | 
			
		||||
                     (destdir (string-append #$output prefix))
 | 
			
		||||
                     (moddirs (cons (string-append #$gtk prefix "/immodules")
 | 
			
		||||
                                    (filter file-exists?
 | 
			
		||||
                                            (map (cut string-append <> prefix "/immodules")
 | 
			
		||||
                                                 '#$(manifest-inputs manifest)))))
 | 
			
		||||
                     (modules (append-map (cut find-files <> "\\.so$")
 | 
			
		||||
                                          moddirs)))
 | 
			
		||||
 | 
			
		||||
                ;; Generate a new immodules cache file.
 | 
			
		||||
                (mkdir-p (string-append #$output prefix))
 | 
			
		||||
                (let ((pipe    (apply open-pipe* OPEN_READ query modules))
 | 
			
		||||
                      (outfile (string-append #$output prefix
 | 
			
		||||
                                              "/immodules-gtk" #$major ".cache")))
 | 
			
		||||
                  (dynamic-wind
 | 
			
		||||
                    (const #t)
 | 
			
		||||
                    (lambda ()
 | 
			
		||||
                      (call-with-output-file outfile
 | 
			
		||||
                        (lambda (out)
 | 
			
		||||
                          (while (not (eof-object? (peek-char pipe)))
 | 
			
		||||
                            (write-char (read-char pipe) out))))
 | 
			
		||||
                      #t)
 | 
			
		||||
                    (lambda ()
 | 
			
		||||
                      (close-pipe pipe)))))))))
 | 
			
		||||
 | 
			
		||||
    ;; Don't run the hook when there's nothing to do.
 | 
			
		||||
    (let ((gexp #~(begin
 | 
			
		||||
                    #$(if gtk+   (build gtk+   "3.0.0")  #t)
 | 
			
		||||
                    #$(if gtk+-2 (build gtk+-2 "2.10.0") #t))))
 | 
			
		||||
      (if (or gtk+ gtk+-2)
 | 
			
		||||
          (gexp->derivation "gtk-im-modules" gexp
 | 
			
		||||
                            #:local-build? #t
 | 
			
		||||
                            #:substitutable? #f)
 | 
			
		||||
          (return #f)))))
 | 
			
		||||
 | 
			
		||||
(define (xdg-desktop-database manifest)
 | 
			
		||||
  "Return a derivation that builds the @file{mimeinfo.cache} database from
 | 
			
		||||
desktop files.  It's used to query what applications can handle a given
 | 
			
		||||
| 
						 | 
				
			
			@ -844,6 +905,7 @@ files for the truetype fonts of the @var{manifest} entries."
 | 
			
		|||
        ghc-package-cache-file
 | 
			
		||||
        ca-certificate-bundle
 | 
			
		||||
        gtk-icon-themes
 | 
			
		||||
        gtk-im-modules
 | 
			
		||||
        xdg-desktop-database
 | 
			
		||||
        xdg-mime-database))
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Reference in a new issue