me
/
guix
Archived
1
0
Fork 0
Code

home: services: Make strings in Gexps translateble. 

* gnu/home/services.scm (%initialize-gettext): New variable.
(compute-on-first-login-script): Use it.
(compute-on-change-gexp): Likewise.
* gnu/home/services/symlink-manager.scm (update-symlinks-script): Likewise.
* po/guix/POTFILES.in: Add gnu/home-services.scm and
gnu/home/services/symlink-manager.scm.

Suggested-by: Ludovic Courtès <ludo@gnu.org>
Link: <https://yhetil.org/guix-bugs/87sfvy8k1u.fsf@gnu.org>
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
master
Xinglu Chen 2021-12-22 16:37:09 +01:00 committed by Ludovic Courtès
parent 2719dfa631
commit cde3376b35
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 69 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
gnu/home/services.scm
View File

@ -19,6 +19,7 @@
(define-module (gnu home services) (define-module (gnu home services)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module ((gnu packages package-management) #:select (guix))
#:use-module (guix channels) #:use-module (guix channels)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix store) #:use-module (guix store)
@ -28,7 +29,7 @@
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix discovery) #:use-module (guix discovery)
#:use-module (guix diagnostics) #:use-module (guix diagnostics)
#:use-module (guix i18n)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -41,7 +42,9 @@
home-run-on-change-service-type home-run-on-change-service-type
home-provenance-service-type home-provenance-service-type
fold-home-service-types) fold-home-service-types
%initialize-gettext)
#:re-export (service #:re-export (service
service-type service-type
@ -274,10 +277,21 @@ directory containing FILES."
(description "Configuration files for programs that (description "Configuration files for programs that
will be put in @file{~/.guix-home/files}."))) will be put in @file{~/.guix-home/files}.")))
(define %initialize-gettext
#~(begin
(bindtextdomain %gettext-domain
(string-append #$guix "/share/locale"))
(textdomain %gettext-domain)
(setlocale LC_ALL "")))
(define (compute-on-first-login-script _ gexps) (define (compute-on-first-login-script _ gexps)
(program-file (program-file
"on-first-login" "on-first-login"
#~(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR") #~(begin
(use-modules (guix i18n))
#$%initialize-gettext
(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR")
(format #f "/run/user/~a" (getuid)))) (format #f "/run/user/~a" (getuid))))
(flag-file-path (string-append (flag-file-path (string-append
xdg-runtime-dir "/on-first-login-executed")) xdg-runtime-dir "/on-first-login-executed"))
@ -289,10 +303,12 @@ will be put in @file{~/.guix-home/files}.")))
(if (file-exists? xdg-runtime-dir) (if (file-exists? xdg-runtime-dir)
(unless (file-exists? flag-file-path) (unless (file-exists? flag-file-path)
(begin #$@gexps (touch flag-file-path))) (begin #$@gexps (touch flag-file-path)))
(display "XDG_RUNTIME_DIR doesn't exists, on-first-login script ;; TRANSLATORS: 'on-first-login' is the name of a service and
;; shouldn't be translated
(display (G_ "XDG_RUNTIME_DIR doesn't exists, on-first-login script
won't execute anything. You can check if xdg runtime directory exists, won't execute anything. You can check if xdg runtime directory exists,
XDG_RUNTIME_DIR variable is set to appropriate value and manually execute the XDG_RUNTIME_DIR variable is set to appropriate value and manually execute the
script by running '$HOME/.guix-home/on-first-login'"))))) script by running '$HOME/.guix-home/on-first-login'")))))))
(define (on-first-login-script-entry on-first-login) (define (on-first-login-script-entry on-first-login)
"Return, as a monadic value, an entry for the on-first-login script "Return, as a monadic value, an entry for the on-first-login script
@ -385,6 +401,10 @@ with one gexp, but many times, and all gexps must be idempotent.")))
(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples) (define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples)
#~(begin #~(begin
(use-modules (guix i18n))
#$%initialize-gettext
(define (equal-regulars? file1 file2) (define (equal-regulars? file1 file2)
"Check if FILE1 and FILE2 are bit for bit identical." "Check if FILE1 and FILE2 are bit for bit identical."
(let* ((cmp-binary #$(file-append (let* ((cmp-binary #$(file-append
@ -449,21 +469,23 @@ with one gexp, but many times, and all gexps must be idempotent.")))
"/gnu/store/non-existing-generation") "/gnu/store/non-existing-generation")
"/" (car x))) "/" (car x)))
(file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x))) (file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x)))
(_ (format #t "Comparing ~a and\n~10t~a..." file1 file2)) (_ (format #t (G_ "Comparing ~a and\n~10t~a...") file1 file2))
(any-changes? (something-changed? file1 file2)) (any-changes? (something-changed? file1 file2))
(_ (format #t " done (~a)\n" (_ (format #t (G_ " done (~a)\n")
(if any-changes? "changed" "same")))) (if any-changes? "changed" "same"))))
(if any-changes? (cadr x) ""))) (if any-changes? (cadr x) "")))
'#$pattern-gexp-tuples)) '#$pattern-gexp-tuples))
(if #$eval-gexps? (if #$eval-gexps?
(begin (begin
(display "Evaling on-change gexps.\n\n") ;;; TRANSLATORS: 'on-change' is the name of a service type, it
;;; probably shouldn't be translated.
(display (G_ "Evaluating on-change gexps.\n\n"))
(for-each primitive-eval expressions-to-eval) (for-each primitive-eval expressions-to-eval)
(display "On-change gexps evaluation finished.\n\n")) (display (G_ "On-change gexps evaluation finished.\n\n")))
(display "\ (display "\
On-change gexps won't be evaluated, disabled by service On-change gexps won't be evaluated; evaluation has been disabled in the
configuration.\n")))) service configuration"))))
(define home-run-on-change-service-type (define home-run-on-change-service-type
(service-type (name 'home-run-on-change) (service-type (name 'home-run-on-change)

42
gnu/home/services/symlink-manager.scm
View File

@ -41,7 +41,9 @@
(use-modules (ice-9 ftw) (use-modules (ice-9 ftw)
(ice-9 curried-definitions) (ice-9 curried-definitions)
(ice-9 match) (ice-9 match)
(srfi srfi-1)) (srfi srfi-1)
(guix i18n))
#$%initialize-gettext
(define ((simplify-file-tree parent) file) (define ((simplify-file-tree parent) file)
"Convert the result produced by `file-system-tree' to less "Convert the result produced by `file-system-tree' to less
verbose and more suitable for further processing format. verbose and more suitable for further processing format.
@ -139,20 +141,21 @@ appear only after all nested items already listed."
(backup-file (backup-file
(lambda (path) (lambda (path)
(mkdir-p backup-dir) (mkdir-p backup-dir)
(format #t "Backing up ~a..." (get-target-path path)) (format #t (G_ "Backing up ~a...") (get-target-path path))
(mkdir-p (dirname (get-backup-path path))) (mkdir-p (dirname (get-backup-path path)))
(rename-file (get-target-path path) (get-backup-path path)) (rename-file (get-target-path path) (get-backup-path path))
(display " done\n"))) (display (G_ " done\n"))))
(cleanup-symlinks (cleanup-symlinks
(lambda () (lambda ()
(let ((to-delete ((file-tree-traverse #f) old-tree))) (let ((to-delete ((file-tree-traverse #f) old-tree)))
(display (display
"Cleaning up symlinks from previous home-environment.\n\n") (G_
"Cleaning up symlinks from previous home-environment.\n\n"))
(map (map
(match-lambda (match-lambda
(('dir . ".") (('dir . ".")
(display "Cleanup finished.\n\n")) (display (G_ "Cleanup finished.\n\n")))
(('dir . path) (('dir . path)
(if (and (if (and
@ -160,12 +163,13 @@ appear only after all nested items already listed."
(directory? (get-target-path path)) (directory? (get-target-path path))
(empty-directory? (get-target-path path))) (empty-directory? (get-target-path path)))
(begin (begin
(format #t "Removing ~a..." (format #t (G_ "Removing ~a...")
(get-target-path path)) (get-target-path path))
(rmdir (get-target-path path)) (rmdir (get-target-path path))
(display " done\n")) (display (G_ " done\n")))
(format (format
#t "Skipping ~a (not an empty directory)... done\n" #t
(G_ "Skipping ~a (not an empty directory)... done\n")
(get-target-path path)))) (get-target-path path))))
(('file . path) (('file . path)
@ -175,12 +179,12 @@ appear only after all nested items already listed."
;; up later during create-symlinks phase. ;; up later during create-symlinks phase.
(if (symlink-to-store? (get-target-path path)) (if (symlink-to-store? (get-target-path path))
(begin (begin
(format #t "Removing ~a..." (get-target-path path)) (format #t (G_ "Removing ~a...") (get-target-path path))
(delete-file (get-target-path path)) (delete-file (get-target-path path))
(display " done\n")) (display (G_ " done\n")))
(format (format
#t #t
"Skipping ~a (not a symlink to store)... done\n" (G_ "Skipping ~a (not a symlink to store)... done\n")
(get-target-path path)))))) (get-target-path path))))))
to-delete)))) to-delete))))
@ -191,9 +195,9 @@ appear only after all nested items already listed."
(match-lambda (match-lambda
(('dir . ".") (('dir . ".")
(display (display
"New symlinks to home-environment will be created soon.\n") (G_ "New symlinks to home-environment will be created soon.\n"))
(format (format
#t "All conflicting files will go to ~a.\n\n" backup-dir)) #t (G_ "All conflicting files will go to ~a.\n\n") backup-dir))
(('dir . path) (('dir . path)
(let ((target-path (get-target-path path))) (let ((target-path (get-target-path path)))
@ -203,20 +207,20 @@ appear only after all nested items already listed."
(if (file-exists? target-path) (if (file-exists? target-path)
(format (format
#t "Skipping ~a (directory already exists)... done\n" #t (G_ "Skipping ~a (directory already exists)... done\n")
target-path) target-path)
(begin (begin
(format #t "Creating ~a..." target-path) (format #t (G_ "Creating ~a...") target-path)
(mkdir target-path) (mkdir target-path)
(display " done\n"))))) (display (G_ " done\n"))))))
(('file . path) (('file . path)
(when (file-exists? (get-target-path path)) (when (file-exists? (get-target-path path))
(backup-file path)) (backup-file path))
(format #t "Symlinking ~a -> ~a..." (format #t (G_ "Symlinking ~a -> ~a...")
(get-target-path path) (get-source-path path)) (get-target-path path) (get-source-path path))
(symlink (get-source-path path) (get-target-path path)) (symlink (get-source-path path) (get-target-path path))
(display " done\n"))) (display (G_ " done\n"))))
to-create))))) to-create)))))
(when old-tree (when old-tree
@ -227,7 +231,7 @@ appear only after all nested items already listed."
(symlink new-home new-he-path) (symlink new-home new-he-path)
(rename-file new-he-path he-path) (rename-file new-he-path he-path)
(display " done\nFinished updating symlinks.\n\n"))))) (display (G_" done\nFinished updating symlinks.\n\n"))))))
(define (update-symlinks-gexp _) (define (update-symlinks-gexp _)

2
po/guix/POTFILES.in
View File

@ -5,6 +5,8 @@ gnu/packages.scm
gnu/services.scm gnu/services.scm
gnu/system.scm gnu/system.scm
gnu/services/shepherd.scm gnu/services/shepherd.scm
gnu/home/services.scm
gnu/home/services/symlink-manager.scm
gnu/system/file-systems.scm gnu/system/file-systems.scm
gnu/system/image.scm gnu/system/image.scm
gnu/system/linux-container.scm gnu/system/linux-container.scm