unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#36000] [PATCH 1/4] guix: Add helper for generating desktop entry files.
@ 2019-05-30  7:11 Pierre Neidhardt
  2019-05-30  8:17 ` [bug#36000] [PATCH 2/4] gnu: emacs-exwm: Use make-desktop-entry-file Pierre Neidhardt
       [not found] ` <handler.36000.B.155920231822519.ack@debbugs.gnu.org>
  0 siblings, 2 replies; 15+ messages in thread
From: Pierre Neidhardt @ 2019-05-30  7:11 UTC (permalink / raw)
  To: 36000

* guix/build/utils.scm (make-desktop-entry-file): New procedure.
---
 guix/build/utils.scm | 99 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 99 insertions(+)

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 5fe3286843..21bdc42719 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -1100,6 +1100,105 @@ with definitions for VARS."
         (chmod prog-tmp #o755)
         (rename-file prog-tmp prog))))
 
+(define* (make-desktop-entry-file destination #:key
+                                  (type "Application") ; One of "Application", "Link" or "Directory".
+                                  (version "1.1")
+                                  name
+                                  (generic-name name)
+                                  (no-display #f)
+                                  comment
+                                  icon
+                                  (hidden #f)
+                                  only-show-in
+                                  not-show-in
+                                  (d-bus-activatable #f)
+                                  try-exec
+                                  exec
+                                  path
+                                  (terminal #f)
+                                  actions
+                                  mime-type
+                                  (categories "Application")
+                                  implements
+                                  keywords
+                                  (startup-notify #t)
+                                  startup-w-m-class
+                                  #:rest all-args)
+  "Create a desktop entry file at DESTINATION.
+You must specify NAME.
+
+Values can be booleans, numbers, strings or list of strings.
+
+Additionally, locales can be specified with an alist where the key is the
+locale.  The #f key specifies the default.  Example:
+
+  #:name '((#f \"I love Guix\") (\"fr\" \"J'aime Guix\"))
+
+produces
+
+  Name=I love Guix
+  Name[fr]=J'aime Guix
+
+For a complete description of the format, see the specifications at
+https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html."
+  (define (escape-semicolon s)
+    (string-join (string-split s #\;) "\\;"))
+  (define* (parse key value #:optional locale)
+    (set! value (match value
+                  (#t "true")
+                  (#f "false")
+                  ((?  number? n) n)
+                  ((?  string? s) (escape-semicolon s))
+                  ((?  list? value)
+                   (catch 'wrong-type-arg
+                     (lambda () (string-join (map escape-semicolon value) ";"))
+                     (lambda args (error "List arguments can only contain strings: ~a" args))))
+                  (_ (error "Value must be a boolean, number, string or list of strings"))))
+    (format #t "~a=~a~%"
+            (if locale
+                (format #f "~a[~a]" key locale)
+                key)
+            value))
+
+  (define key-error-message "This procedure only takes key arguments beside DESTINATION")
+
+  (unless name
+    (error "Missing NAME key argument"))
+  (unless (member #:type all-args)
+    (set! all-args (append (list #:type type) all-args)))
+  (mkdir-p (dirname destination))
+
+  (with-output-to-file destination
+    (lambda ()
+      (format #t "[Desktop Entry]~%")
+      (let loop ((args all-args))
+        (match args
+          (() #t)
+          ((_) (error key-error-message))
+          ((key value . ...)
+           (unless (keyword? key)
+             (error key-error-message))
+           (set! key
+                 (string-join (map string-titlecase
+                                   (string-split (symbol->string
+                                                  (keyword->symbol key))
+                                                 #\-))
+                              ""))
+           (match value
+             (((_ . _) . _)
+              (for-each (lambda (locale-subvalue)
+                          (parse key
+                                 (if (and (list? (cdr locale-subvalue))
+                                          (= 1 (length (cdr locale-subvalue))))
+                                     ;; Support both proper and improper lists for convenience.
+                                     (cadr locale-subvalue)
+                                     (cdr locale-subvalue))
+                                 (car locale-subvalue)))
+                        value))
+             (_
+              (parse key value)))
+           (loop (cddr args))))))))
+
 \f
 ;;;
 ;;; Locales.
-- 
2.21.0

^ permalink raw reply related	[flat|nested] 15+ messages in thread
end of thread, other threads:[~2019-10-19 10:47 UTC | newest]

Thread overview: 15+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-05-30  7:11 [bug#36000] [PATCH 1/4] guix: Add helper for generating desktop entry files Pierre Neidhardt
2019-05-30  8:17 ` [bug#36000] [PATCH 2/4] gnu: emacs-exwm: Use make-desktop-entry-file Pierre Neidhardt
2019-05-30  8:17   ` [bug#36000] [PATCH 3/4] gnu: tome4: " Pierre Neidhardt
2019-05-30  8:17   ` [bug#36000] [PATCH 4/4] gnu: drascula: " Pierre Neidhardt
     [not found] ` <handler.36000.B.155920231822519.ack@debbugs.gnu.org>
2019-10-12  8:43   ` [bug#36000] Acknowledgement ([PATCH 1/4] guix: Add helper for generating desktop entry files.) Pierre Neidhardt
2019-10-12 18:44     ` Efraim Flashner
2019-10-12 19:05       ` Pierre Neidhardt
2019-10-12 19:12         ` Efraim Flashner
2019-10-18  8:43           ` Pierre Neidhardt
2019-10-18 14:40             ` Ludovic Courtès
2019-10-18 15:10               ` Marius Bakke
2019-10-18 15:13             ` Marius Bakke
2019-10-18 15:22               ` Pierre Neidhardt
2019-10-18 15:24                 ` Marius Bakke
2019-10-19 10:46                   ` Pierre Neidhardt

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).