summaryrefslogtreecommitdiff
path: root/gnu/services/configuration.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/configuration.scm')
-rw-r--r--gnu/services/configuration.scm303
1 files changed, 219 insertions, 84 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 90f12a8d39..df3d3b6f9b 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -2,6 +2,8 @@
;;; Copyright © 2015 Andy Wingo <[email protected]>
;;; Copyright © 2017 Mathieu Othacehe <[email protected]>
;;; Copyright © 2017, 2018 Clément Lassieur <[email protected]>
+;;; Copyright © 2021 Xinglu Chen <[email protected]>
+;;; Copyright © 2021 Maxim Cournoyer <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,10 +25,12 @@
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module ((guix utils) #:select (source-properties->location))
+ #:use-module ((guix diagnostics) #:select (location-file))
+ #:use-module ((guix modules) #:select (file-name->module-name))
#:autoload (texinfo) (texi-fragment->stexi)
#:autoload (texinfo serialize) (stexi->texi)
#:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (append-map))
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (configuration-field
@@ -38,11 +42,20 @@
configuration-field-getter
configuration-field-default-value-thunk
configuration-field-documentation
+
+ configuration-error?
+
+ define-configuration
+ define-configuration/no-serialization
+ no-serialization
+
serialize-configuration
define-maybe
- define-configuration
+ define-maybe/no-serialization
validate-configuration
generate-documentation
+ configuration->documentation
+ empty-serializer
serialize-package))
;;; Commentary:
@@ -63,6 +76,10 @@
(define (configuration-missing-field kind field)
(configuration-error
(format #f "~a configuration missing required field ~a" kind field)))
+(define (configuration-no-default-value kind field)
+ (configuration-error
+ (format #f "The field `~a' of the `~a' configuration record \
+does not have a default value" field kind)))
(define-record-type* <configuration-field>
configuration-field make-configuration-field configuration-field?
@@ -91,100 +108,218 @@
fields))
(define-syntax-rule (id ctx parts ...)
- "Assemble PARTS into a raw (unhygienic) identifier."
+ "Assemble PARTS into a raw (unhygienic) identifier."
(datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
+(define (define-maybe-helper serialize? prefix syn)
+ (syntax-case syn ()
+ ((_ stem)
+ (with-syntax
+ ((stem? (id #'stem #'stem #'?))
+ (maybe-stem? (id #'stem #'maybe- #'stem #'?))
+ (serialize-stem (if prefix
+ (id #'stem prefix #'serialize- #'stem)
+ (id #'stem #'serialize- #'stem)))
+ (serialize-maybe-stem (if prefix
+ (id #'stem prefix #'serialize-maybe- #'stem)
+ (id #'stem #'serialize-maybe- #'stem))))
+ #`(begin
+ (define (maybe-stem? val)
+ (or (eq? val 'disabled) (stem? val)))
+ #,@(if serialize?
+ (list #'(define (serialize-maybe-stem field-name val)
+ (if (stem? val)
+ (serialize-stem field-name val)
+ "")))
+ '()))))))
+
(define-syntax define-maybe
(lambda (x)
- (syntax-case x ()
+ (syntax-case x (no-serialization prefix)
+ ((_ stem (no-serialization))
+ (define-maybe-helper #f #f #'(_ stem)))
+ ((_ stem (prefix serializer-prefix))
+ (define-maybe-helper #t #'serializer-prefix #'(_ stem)))
((_ stem)
- (with-syntax
- ((stem? (id #'stem #'stem #'?))
- (maybe-stem? (id #'stem #'maybe- #'stem #'?))
- (serialize-stem (id #'stem #'serialize- #'stem))
- (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
- #'(begin
- (define (maybe-stem? val)
- (or (eq? val 'disabled) (stem? val)))
- (define (serialize-maybe-stem field-name val)
- (if (stem? val) (serialize-stem field-name val) ""))))))))
+ (define-maybe-helper #t #f #'(_ stem))))))
+
+(define-syntax-rule (define-maybe/no-serialization stem)
+ (define-maybe stem (no-serialization)))
+
+(define (define-configuration-helper serialize? serializer-prefix syn)
+ (syntax-case syn ()
+ ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
+ (with-syntax (((field-getter ...)
+ (map (lambda (field)
+ (id #'stem #'stem #'- field))
+ #'(field ...)))
+ ((field-predicate ...)
+ (map (lambda (type)
+ (id #'stem type #'?))
+ #'(field-type ...)))
+ ((field-default ...)
+ (map (match-lambda
+ ((field-type default-value)
+ default-value)
+ ((field-type)
+ ;; Quote `undefined' to prevent a possibly
+ ;; unbound warning.
+ (syntax 'undefined)))
+ #'((field-type def ...) ...)))
+ ((field-serializer ...)
+ (map (lambda (type custom-serializer)
+ (and serialize?
+ (match custom-serializer
+ ((serializer)
+ serializer)
+ (()
+ (if serializer-prefix
+ (id #'stem
+ serializer-prefix
+ #'serialize- type)
+ (id #'stem #'serialize- type))))))
+ #'(field-type ...)
+ #'((custom-serializer ...) ...))))
+ #`(begin
+ (define-record-type* #,(id #'stem #'< #'stem #'>)
+ #,(id #'stem #'% #'stem)
+ #,(id #'stem #'make- #'stem)
+ #,(id #'stem #'stem #'?)
+ (%location #,(id #'stem #'stem #'-location)
+ (default (and=> (current-source-location)
+ source-properties->location))
+ (innate))
+ #,@(map (lambda (name getter def)
+ (if (eq? (syntax->datum def) (quote 'undefined))
+ #`(#,name #,getter)
+ #`(#,name #,getter (default #,def))))
+ #'(field ...)
+ #'(field-getter ...)
+ #'(field-default ...)))
+ (define #,(id #'stem #'stem #'-fields)
+ (list (configuration-field
+ (name 'field)
+ (type 'field-type)
+ (getter field-getter)
+ (predicate field-predicate)
+ (serializer field-serializer)
+ (default-value-thunk
+ (lambda ()
+ (display '#,(id #'stem #'% #'stem))
+ (if (eq? (syntax->datum field-default)
+ 'undefined)
+ (configuration-no-default-value
+ '#,(id #'stem #'% #'stem) 'field)
+ field-default)))
+ (documentation doc))
+ ...))
+ (define-syntax-rule (stem arg (... ...))
+ (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
+ (validate-configuration conf
+ #,(id #'stem #'stem #'-fields))
+ conf)))))))
+
+(define no-serialization ;syntactic keyword for 'define-configuration'
+ '(no serialization))
(define-syntax define-configuration
- (lambda (stx)
- (syntax-case stx ()
- ((_ stem (field (field-type def) doc) ...)
- (with-syntax (((field-getter ...)
- (map (lambda (field)
- (id #'stem #'stem #'- field))
- #'(field ...)))
- ((field-predicate ...)
- (map (lambda (type)
- (id #'stem type #'?))
- #'(field-type ...)))
- ((field-serializer ...)
- (map (lambda (type)
- (id #'stem #'serialize- type))
- #'(field-type ...))))
- #`(begin
- (define-record-type* #,(id #'stem #'< #'stem #'>)
- #,(id #'stem #'% #'stem)
- #,(id #'stem #'make- #'stem)
- #,(id #'stem #'stem #'?)
- (%location #,(id #'stem #'-location)
- (default (and=> (current-source-location)
- source-properties->location))
- (innate))
- (field field-getter (default def))
- ...)
- (define #,(id #'stem #'stem #'-fields)
- (list (configuration-field
- (name 'field)
- (type 'field-type)
- (getter field-getter)
- (predicate field-predicate)
- (serializer field-serializer)
- (default-value-thunk (lambda () def))
- (documentation doc))
- ...))
- (define-syntax-rule (stem arg (... ...))
- (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
- (validate-configuration conf
- #,(id #'stem #'stem #'-fields))
- conf))))))))
-
-(define (serialize-package field-name val)
- "")
+ (lambda (s)
+ (syntax-case s (no-serialization prefix)
+ ((_ stem (field (field-type def ...) doc custom-serializer ...) ...
+ (no-serialization))
+ (define-configuration-helper
+ #f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
+ ...)))
+ ((_ stem (field (field-type def ...) doc custom-serializer ...) ...
+ (prefix serializer-prefix))
+ (define-configuration-helper
+ #t #'serializer-prefix #'(_ stem (field (field-type def ...)
+ doc custom-serializer ...)
+ ...)))
+ ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
+ (define-configuration-helper
+ #t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
+ ...))))))
+
+(define-syntax-rule (define-configuration/no-serialization
+ stem (field (field-type def ...)
+ doc custom-serializer ...) ...)
+ (define-configuration stem (field (field-type def ...)
+ doc custom-serializer ...) ...
+ (no-serialization)))
+
+(define (empty-serializer field-name val) "")
+(define serialize-package empty-serializer)
;; A little helper to make it easier to document all those fields.
(define (generate-documentation documentation documentation-name)
(define (str x) (object->string x))
+
+ (define (package->symbol package)
+ "Return the first symbol name of a package that matches PACKAGE, else #f."
+ (let* ((module (file-name->module-name
+ (location-file (package-location package))))
+ (symbols (filter-map
+ identity
+ (module-map (lambda (symbol var)
+ (and (equal? package (variable-ref var))
+ symbol))
+ (resolve-module module)))))
+ (if (null? symbols)
+ #f
+ (first symbols))))
+
(define (generate configuration-name)
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
- `((para "Available " (code ,(str configuration-name)) " fields are:")
- ,@(map
- (lambda (f)
- (let ((field-name (configuration-field-name f))
- (field-type (configuration-field-type f))
- (field-docs (cdr (texi-fragment->stexi
- (configuration-field-documentation f))))
- (default (catch #t
- (configuration-field-default-value-thunk f)
- (lambda _ '%invalid))))
- (define (show-default? val)
- (or (string? val) (number? val) (boolean? val)
- (and (symbol? val) (not (eq? val '%invalid)))
- (and (list? val) (and-map show-default? val))))
- `(deftypevr (% (category
- (code ,(str configuration-name)) " parameter")
- (data-type ,(str field-type))
- (name ,(str field-name)))
- ,@field-docs
- ,@(if (show-default? default)
- `((para "Defaults to " (samp ,(str default)) "."))
- '())
- ,@(append-map
- generate
- (or (assq-ref sub-documentation field-name) '())))))
- fields)))))
+ `((deftp (% (category "Data Type") (name ,(str configuration-name)))
+ (para "Available " (code ,(str configuration-name)) " fields are:")
+ (table
+ (% (formatter (asis)))
+ ,@(map
+ (lambda (f)
+ (let ((field-name (configuration-field-name f))
+ (field-type (configuration-field-type f))
+ (field-docs (cdr (texi-fragment->stexi
+ (configuration-field-documentation f))))
+ (default (catch #t
+ (configuration-field-default-value-thunk f)
+ (lambda _ '%invalid))))
+ (define (show-default? val)
+ (or (string? val) (number? val) (boolean? val)
+ (package? val)
+ (and (symbol? val) (not (eq? val '%invalid)))
+ (and (list? val) (and-map show-default? val))))
+
+ (define (show-default val)
+ (cond
+ ((package? val)
+ (symbol->string (package->symbol val)))
+ (else (str val))))
+
+ `(entry (% (heading
+ (code ,(str field-name))
+ ,@(if (show-default? default)
+ `(" (default: "
+ (code ,(show-default default)) ")")
+ '())
+ " (type: " ,(str field-type) ")"))
+ (para ,@field-docs)
+ ,@(append-map
+ generate
+ (or (assq-ref sub-documentation field-name)
+ '())))))
+ fields)))))))
(stexi->texi `(*fragment* . ,(generate documentation-name))))
+
+(define (configuration->documentation configuration-symbol)
+ "Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when
+defining a configuration record with DEFINE-CONFIGURATION, and output the
+Texinfo documentation of its fields."
+ ;; This is helper for a simple, straight-forward application of
+ ;; GENERATE-DOCUMENTATION.
+ (let ((fields-getter (module-ref (current-module)
+ (symbol-append configuration-symbol
+ '-fields))))
+ (display (generate-documentation `((,configuration-symbol ,fields-getter))
+ configuration-symbol))))
generated by cgit v1.2.3 (git 2.45.2) at 2025-04-16 22:54:12 +0000