Import home-services-utils from rde.

* rosenthal/utils/home-services-utils.scm: New file imported from rde.
<https://git.sr.ht/~abcdw/rde/tree/master/item/gnu/home-services-utils.scm>

rosenthal/utils/home-services-utils.scm

@@ -0,0 +1,441 @@
+;; SPDX-FileCopyrightText: 2021 Xinglu Chen <public@yoctocell.xyz>
+;; SPDX-FileCopyrightText: 2021 Andrew Tropin <andrew@trop.in>
+;;
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+(define-module (rosenthal utils home-services-utils)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu home services utils)
+  #:use-module (guix ui)
+  #:use-module (guix diagnostics)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix i18n)
+  #:use-module (guix profiles)
+  #:use-module (guix packages)
+  #:use-module (guix build-system trivial)
+  #:use-module (guix deprecation)
+
+  #:use-module (ice-9 curried-definitions)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 string-fun)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-171)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-43)
+
+  #:re-export (filter-configuration-fields
+
+               list-of
+
+               list-of-strings?
+               alist?
+               text-config?
+               serialize-text-config
+               generic-serialize-alist-entry
+               generic-serialize-alist
+
+               maybe-object->string
+               object->snake-case-string
+               object->camel-case-string)
+
+  #:export (slurp-file-gexp
+
+            alist-entry->mixed-text
+            boolean->yes-or-no
+            boolean->true-or-false
+            list->human-readable-list
+
+            ini-config?
+            generic-serialize-ini-config
+            generic-serialize-git-ini-config
+
+            yaml-config?
+            serialize-yaml-config
+
+            string-or-gexp?
+            serialize-string-or-gexp
+
+            gexp-text-config?
+            serialize-gexp-text-config
+
+            rest
+            maybe-list
+            optional
+            wrap-package
+
+            define-enum
+            enum-name
+            enum-value))
+
+
+;;;
+;;; User's utils.
+;;;
+
+(define* (slurp-file-gexp file #:key (encoding "UTF-8"))
+  "Returns a gexp, which reads all the content of the FILE and returns
+it as a string.  FILE must be a file-like object."
+  (when (not (file-like? file))
+    (raise (formatted-message
+            (G_ "~a is not a file-like object.")
+            file)))
+  #~(call-with-input-file #$file
+      (@ (ice-9 textual-ports) get-string-all)
+      #:encoding #$encoding))
+
+(define-deprecated/alias slurp-file-gexp slurp-file-like)
+
+
+;;;
+;;; Configuration related helpers.
+;;;
+
+(define* ((alist-entry->mixed-text prefix sep #:optional (suffix "\n"))
+          alist-entry)
+  "Create a list from ALIST-ENTRY, which can be used with
+@code{mixed-text-file} for example to create key-value configuration
+file or shell script.
+
+PREFIX is the string to prefix the key-value pair with.  For example,
+@code{\"export\"} will return @code{'(\"export\" KEY SEP VALUE)},
+where KEY is the first element of ALIST-ENTRY, and VALUE is the second
+element of ALIST-ENTRY.
+
+SEP is the separator between the key and the value.
+
+SUFFIX is the optional argument, default to newline.
+
+Different things will happen depending on the value of VALUE:
+@itemize @bullet
+@item If VALUE is #f, ignore everything in the entry and just return
+an empty list.
+
+@item If VALUE is #t or not provided (empty list), ignore the VALUE
+and SEP and just return a list of PREFIX and KEY followed by a
+SUFFIX.
+
+@item If VALUE is a flat list, it will get added to the resulting
+list. If not flat the exception will be raised.
+
+@item If VALUE is not a list (string, file-like object, etc), return a
+list of PREFIX, KEY, SEP and VALUE followed by a SUFFIX.
+
+The following code
+@lisp
+((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\" . \"emacsclient\"))
+((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\" . #t))
+((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\"))
+((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\" . #f))
+((alist-entry->mixed-text \"export \" \"=\") '(\"EDITOR\" . (\"emacsclient\" \"vim\")))
+@end lisp
+
+would yield
+
+@example
+(\"export \" \"EDITOR\" \"=\" \"emacsclient\" \"\n\")
+(\"export \" \"EDITOR\" \"\n\")
+(\"export \" \"EDITOR\" \"\n\")
+()
+(\"export \" \"EDITOR\" \"=\" \"emacsclient\" \"vim\" \"\n\")
+@end example"
+  (define (not-alist-entry-error)
+    (raise (formatted-message
+            (G_ "~a has to be an association list entry")
+            alist-entry)))
+  (match alist-entry
+    ((key . value)
+     (let* ((values (cond
+                    ((eq? value #f)
+                     #f)
+                    ((or (eq? value #t) (null? value))
+                     '(""))
+                    ((list? value)
+                     (if (any list? value)
+                         (raise (formatted-message
+                                 (G_ "~a is not a flat list")
+                                 value))
+                         value))
+                    (else
+                     (list value))))
+           (sep (if (eq? values '(""))
+                    ""
+                    sep)))
+       (if values
+           `(,prefix ,key ,sep ,@values ,suffix)
+           '())))
+    (_ (not-alist-entry-error))))
+
+(define* (boolean->yes-or-no bool #:optional (capitalize? #f))
+  "Convert a boolean BOOL to \"yes\" or \"no\".
+Setting CAPITALIZE? to @code{#t} will capitalize the word, it is set to
+@code{#f} by default."
+  (let ((word (if (eq? bool #t) "yes" "no")))
+    (if capitalize?
+        (string-capitalize word)
+        word)))
+
+(define* (boolean->true-or-false bool #:optional (capitalize? #f))
+  "Convert a boolean BOOL to \"true\" or \"false\".
+Setting CAPITALIZE? to @code{#t} will capitalize the word, it is set to
+@code{#f} by default."
+  (let ((word (if bool "true" "false")))
+    (if capitalize?
+        (string-capitalize word)
+        word)))
+
+;; TODO: Remove once upstreamed
+(define* (list->human-readable-list lst
+                                    #:key
+                                    (cumulative? #f)
+                                    (proc identity))
+  "Turn a list LST into a sequence of terms readable by humans.
+If CUMULATIVE? is @code{#t}, use ``and'', otherwise use ``or'' before
+the last term.
+
+PROC is a procedure to apply to each of the elements of a list before
+turning them into a single human readable string.
+
+@example
+(list->human-readable-list '(1 4 9) #:cumulative? #t #:proc sqrt)
+@result{} \"1, 2, and 3\"
+@end example
+
+yields:"
+  (let* ((word (if cumulative? "and " "or "))
+         (init (append (drop-right lst 1))))
+    (format #f "~a" (string-append
+                     (string-join
+                      (map (compose maybe-object->string proc) init)
+                      ", " 'suffix)
+                     word
+                     (maybe-object->string (proc (last lst)))))))
+
+
+
+;;;
+;;; Serializers.
+;;;
+
+(define ini-config? list?)
+(define (generic-serialize-ini-config-section section proc)
+  "Format a section from SECTION for an INI configuration.
+Apply the procedure PROC on SECTION after it has been converted to a string"
+  (format #f "[~a]\n" (proc section)))
+
+(define default-ini-format-section
+  (match-lambda
+    ((section subsection)
+     (string-append (maybe-object->string section) " "
+                    (maybe-object->string subsection)))
+    (section
+     (maybe-object->string section))))
+
+(define* (generic-serialize-ini-config
+          #:key
+          (combine-ini string-join)
+          (combine-alist string-append)
+          (combine-section-alist string-append)
+          (format-section default-ini-format-section)
+          serialize-field
+          fields)
+  "Create an INI configuration from nested lists FIELDS.  This uses
+@code{generic-serialize-ini-config-section} and @{generic-serialize-alist} to
+serialize the section and the association lists, respectively.
+
+@example
+(generic-serialize-ini-config
+ #:serialize-field (lambda (a b) (format #f \"~a = ~a\n\" a b))
+ #:format-section (compose string-capitalize symbol->string)
+ #:fields '((application ((key . value)))))
+@end example
+
+@result{} \"[Application]\nkey = value\n\""
+  (combine-ini
+   (map (match-lambda
+          ((section alist)
+           (combine-section-alist
+            (generic-serialize-ini-config-section section format-section)
+            (generic-serialize-alist combine-alist serialize-field alist))))
+        fields)
+   "\n"))
+
+(define* (generic-serialize-git-ini-config
+          #:key
+          (combine-ini string-join)
+          (combine-alist string-append)
+          (combine-section-alist string-append)
+          (format-section default-ini-format-section)
+          serialize-field
+          fields)
+  "Like @code{generic-serialize-ini-config}, but the section can also
+have a @dfn{subsection}.  FORMAT-SECTION will take a list of two
+elements: the section and the subsection."
+  (combine-ini
+   (map (match-lambda
+          ((section subsection alist)
+           (combine-section-alist
+            (generic-serialize-ini-config-section
+             (list section subsection) format-section)
+            (generic-serialize-alist combine-alist serialize-field alist)))
+          ((section alist)
+           (combine-section-alist
+            (generic-serialize-ini-config-section section format-section)
+            (generic-serialize-alist combine-alist serialize-field alist))))
+        fields)
+   "\n"))
+
+(define yaml-config? list?)
+(define (make-yaml-indent depth)
+  (make-string (* 2 depth) #\space))
+
+(define ((serialize-yaml-value depth) value)
+  (let* ((tab (make-yaml-indent depth)))
+    (cond
+     ((string? value)
+      (list (format #f "'~a'" value)))
+     ((boolean? value)
+      (list (format #f "~a" (if value "true" "false"))))
+     ((file-like? value)
+      (list value))
+     ((alist? value)
+      (serialize-yaml-alist value #:depth (1+ depth)))
+     ((vector? value)
+      (serialize-yaml-vector value #:depth depth))
+     (else (list (format #f "~a" value))))))
+
+(define ((serialize-yaml-key depth) key)
+  (when (vector? key)
+    (raise (formatted-message
+            (G_ "Vector as key value are not supported by serializer, \
+try to avoid them. ~a") key)))
+  ((serialize-yaml-value depth) key))
+
+(define ((serialize-yaml-key-value depth) key value)
+  (let ((tab (make-yaml-indent depth)))
+    `("\n"
+      ,tab
+      ,@((serialize-yaml-key depth) key) ": "
+      ,@((serialize-yaml-value depth) value))))
+
+(define ((serialize-yaml-vector-elem depth) elem)
+  (let ((tab (make-yaml-indent (1+ depth))))
+    (cons*
+     "\n" tab "- "
+     ((serialize-yaml-value (1+ depth)) elem))))
+
+(define* (serialize-yaml-vector vec #:key (depth 0))
+  (append-map (serialize-yaml-vector-elem depth) (vector->list vec)))
+
+(define* (serialize-yaml-alist lst #:key (depth 0))
+  (generic-serialize-alist append (serialize-yaml-key-value depth) lst))
+
+(define (serialize-yaml-config config)
+  "Simplified yaml serializer, which supports only a subset of yaml, use
+it with caution."
+  (serialize-yaml-alist config))
+
+(define (string-or-gexp? sg) (or (string? sg) (gexp? sg)))
+(define (serialize-string-or-gexp field-name val) "")
+
+;; Guix proper has a different version of text-config.
+(define (gexp-text-config? config)
+  (and (list? config) (every string-or-gexp? config)))
+(define (serialize-gexp-text-config field-name val)
+  #~(string-append #$@(interpose val "\n" 'suffix)))
+
+;;;
+;;; Miscellaneous.
+;;;
+
+(define rest cdr)
+
+;; Confusing with maybe-list type.
+(define (maybe-list a)
+  "If A is a list, return it, otherwise return a singleton list with A."
+      (if (list? a)
+          a
+          (list a)))
+
+;; If EXPR1 evaluates to a non-@code{#f} value and EXPR2 is specified,
+;; return EXPR2; if it isn't specified, return EXPR1.  Otherwise, return
+;; an empty list @code{'()}.
+(define-syntax optional
+  (syntax-rules ()
+    ((_ expr1)
+     (if expr1 expr1 '()))
+    ((_ expr1 expr2)
+     (if expr1 expr2 '()))))
+
+(define (wrap-package pkg executable-name gexp)
+  "Create a @code{<package>} object that is a wrapper for PACKAGE, and
+runs GEXP.  NAME is the name of the executable that will be put in the store."
+  (let* ((wrapper-name (string-append executable-name "-wrapper"))
+         (wrapper (program-file wrapper-name gexp)))
+    (package
+      (inherit pkg)
+      (name wrapper-name)
+      (source wrapper)
+      (propagated-inputs `((,(package-name pkg) ,pkg)))
+      (build-system trivial-build-system)
+      (arguments
+       `(#:modules
+         ((guix build utils))
+         #:builder
+         (begin
+           (use-modules (guix build utils)
+                        (srfi srfi-1))
+           (let* ((bin (string-append %output "/bin"))
+                  (wrapper (assoc-ref %build-inputs "source")))
+             (mkdir-p bin)
+             (copy-file wrapper (string-append bin "/" ,executable-name)))))))))
+
+
+;;;
+;;; Enums.
+;;;
+
+(define-record-type <enum>
+  (make-enum name value)
+  enum?
+  (name enum-name)
+  (value enum-value))
+
+;; Copied from (gnu services configuration)
+(define-syntax-rule (id ctx parts ...)
+  "Assemble PARTS into a raw (unhygienic)  identifier."
+  (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
+
+;; (define-enum pinentry-flavor
+;;   '(emacs gtk qt ncurses tty))
+;;
+;; (pinentry-flavor? 'gtk)
+;; => #t
+;;
+;; (enum-value pinentry-flavor)
+;; => '(emacs gtk qt ncurses tty)
+;;
+;; (pinentry-flavor? 'vim)
+;; exception: `pinetry-flavor' must be one of `emacs', `gtk', `qt',
+;; `ncurses', or `tty', was given `vim'
+
+(define-syntax define-enum
+  (lambda (x)
+    (syntax-case x ()
+      ((_ stem value)
+       (with-syntax ((stem? (id #'stem #'stem #'?))
+                     (msg (list->human-readable-list
+                           (second (syntax->datum #'value))
+                           #:proc (cut format #f "`~a'" <>))))
+         #'(begin
+             (define stem (make-enum (quote stem) value))
+
+             (define (stem? val)
+               (if (member val value)
+                   #t
+                   (raise (formatted-message
+                           (G_ "`~a' must of ~a, was given: ~s")
+                           (enum-name stem)
+                           (syntax->datum msg)
+                           val))))))))))