gnu: Properly credit Konrad Hinsen.

[jackhill/guix/guix.git] / guix / scripts.scm

diff --git a/guix/scripts.scm b/guix/scripts.scm
index 3e19e38..9792aae 100644 (file)
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,7 +34,12 @@
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
-  #:export (args-fold*
+  #:export (synopsis
+            category
+            define-command
+            %command-categories
+
+            args-fold*
             parse-command-line
             maybe-build
             build-package
@@ -49,12 +55,67 @@
 ;;;
 ;;; Code:
 
-(define (args-fold* options unrecognized-option-proc operand-proc . seeds)
+;; Syntactic keywords.
+(define synopsis 'command-synopsis)
+(define category 'command-category)
+
+(define-syntax define-command-categories
+  (syntax-rules (G_)
+    "Define command categories."
+    ((_ name assert-valid (identifiers (G_ synopses)) ...)
+     (begin
+       (define-public identifiers
+         ;; Define and export syntactic keywords.
+         (list 'syntactic-keyword-for-command-category))
+       ...
+
+       (define-syntax assert-valid
+         ;; Validate at expansion time that we're passed a valid category.
+         (syntax-rules (identifiers ...)
+           ((_ identifiers) #t)
+           ...))
+
+       (define name
+         ;; Alist mapping category name to synopsis.
+         `((identifiers . synopses) ...))))))
+
+;; Command categories.
+(define-command-categories %command-categories
+  assert-valid-command-category
+  (main        (G_ "main commands"))
+  (development (G_ "software development commands"))
+  (packaging   (G_ "packaging commands"))
+  (plumbing    (G_ "plumbing commands"))
+  (internal    (G_ "internal commands")))
+
+(define-syntax define-command
+  (syntax-rules (category synopsis)
+    "Define the given command as a procedure along with its synopsis and,
+optionally, its category.  The synopsis becomes the docstring of the
+procedure, but both the category and synopsis are meant to be read (parsed) by
+'guix help'."
+    ;; The (synopsis ...) form is here so that xgettext sees those strings as
+    ;; translatable.
+    ((_ (name . args)
+        (synopsis doc) body ...)
+     (define (name . args)
+       doc
+       body ...))
+    ((_ (name . args)
+        (category cat) (synopsis doc)
+        body ...)
+     (begin
+       (assert-valid-command-category cat)
+       (define (name . args)
+         doc
+         body ...)))))
+
+(define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
   "A wrapper on top of `args-fold' that does proper user-facing error
 reporting."
   (catch 'misc-error
     (lambda ()
-      (apply args-fold options unrecognized-option-proc
+      (apply args-fold args options unrecognized-option-proc
              operand-proc seeds))
     (lambda (key proc msg args . rest)
       ;; XXX: MSG is not i18n'd.