From 84da61950d4a4038f76fdb9f66e0bbbb71f75385 Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Mon, 11 Oct 2021 18:00:15 +0200 Subject: [PATCH] Nested commands help message --- Makefile.am | 1 + click.scm | 40 +++++++++-------- click/command.scm | 73 +++++++++++++++++++++++++++++++ click/help.scm | 103 +++++++++++++++++++++++++++++++------------- examples/hello.scm | 16 +++---- examples/nested.scm | 20 ++++----- 6 files changed, 186 insertions(+), 67 deletions(-) create mode 100644 click/command.scm diff --git a/Makefile.am b/Makefile.am index 8a78d8d..976d004 100644 --- a/Makefile.am +++ b/Makefile.am @@ -40,6 +40,7 @@ godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache SOURCES = \ click.scm \ + click/command.scm \ click/constant.scm \ click/help.scm \ click/util.scm \ diff --git a/click.scm b/click.scm index d2da6ac..e8f8c09 100644 --- a/click.scm +++ b/click.scm @@ -19,6 +19,9 @@ (define-module (click) #:use-module (ice-9 getopt-long) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (click command) #:use-module (click constant) #:use-module (click help) #:use-module (click util) @@ -27,26 +30,25 @@ group)) -(define (command option-spec procedure) +(define* (command #:key (name #f) (option-spec '()) (help "") (procedure #f)) "Define a new command for the procedure" - (lambda (args) - (let* ((click-option-spec (append option-spec (list HELP_OPTION))) - (values (getopt-long args - (getopt-long-option-spec click-option-spec)))) - (if (option-ref values 'help #f) - (let ((program-name (car args))) - (display-help program-name procedure click-option-spec)) - (apply procedure (map cdr (get-values option-spec values))))))) + (group #:name name + #:option-spec option-spec + #:help help + #:procedure procedure)) -(define (group option-spec target . commands) +(define* (group #:key (name #f) (option-spec '()) (help "") (procedure #f) (commands '())) "Define a new group with a list of commands associated" - (lambda (args) - (let* ((click-option-spec (append option-spec (list HELP_OPTION))) - (values (getopt-long args - (getopt-long-option-spec click-option-spec)))) - (if (or (null? (cdr args)) - (option-ref values 'help #f)) - (let ((program-name (car args))) - (display-help program-name target click-option-spec commands)) - (apply target (map cdr (get-values option-spec values))))))) + (let* ((click-option-spec (append option-spec (list HELP_OPTION))) + (new-command (make-command name click-option-spec help procedure commands))) + (let ((click-manager + (lambda (args) + (let ((values + (getopt-long args (getopt-long-option-spec click-option-spec)))) + (if (option-ref values 'help #f) + (let ((program-name (car args))) + (display-help program-name new-command)) + (apply procedure (map cdr (get-values option-spec values)))))))) + (set-command-click-manager! new-command click-manager) + new-command))) diff --git a/click/command.scm b/click/command.scm new file mode 100644 index 0000000..d60ea1d --- /dev/null +++ b/click/command.scm @@ -0,0 +1,73 @@ +;;; Click --- Command Line Interface Creation Kit for GNU Guile +;;; Copyright © 2021 Javier Sancho +;;; +;;; This file is part of Click. +;;; +;;; Click is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Click is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Click. If not, see . + + +(define-module (click command) + #:export (command? + command-commands + command-help-text + command-name + command-option-spec + command-procedure + group? + make-command + set-command-click-manager!)) + + +;; Command VTable +(define (make-struct/no-tail 'pwpwpwpwpwpw)) + +(define (command-printer struct port) + (let ((type (if (group? struct) "Group" "Command")) + (name (command-name struct))) + (if name + (format port "<~a ~a>" type name) + (format port "<~a>" type)))) + +(struct-set! vtable-index-printer command-printer) + + +;; Command API +(define (make-command name option-spec help-text procedure commands) + (make-struct/no-tail #f name option-spec help-text procedure commands)) + +(define (set-command-click-manager! command click-manager) + (struct-set! command 0 click-manager)) + +(define (command-name command) + (struct-ref command 1)) + +(define (command-option-spec command) + (struct-ref command 2)) + +(define (command-help-text command) + (struct-ref command 3)) + +(define (command-procedure command) + (struct-ref command 4)) + +(define (command-commands command) + (struct-ref command 5)) + +(define (command? command) + (and (equal? (struct-vtable command) ) + (null? (command-commands command)))) + +(define (group? command) + (and (equal? (struct-vtable command) ) + (not (null? (command-commands command))))) diff --git a/click/help.scm b/click/help.scm index f397031..9d0c5cc 100644 --- a/click/help.scm +++ b/click/help.scm @@ -19,6 +19,7 @@ (define-module (click help) #:use-module (ice-9 format) + #:use-module (click command) #:use-module (click util) #:export (display-error display-help)) @@ -29,41 +30,39 @@ (assoc-ref (option-type option) 'description)) -(define (get-title target) +(define* (get-help-text procedure #:optional (help-text "")) "Return the title for the help message" - (cond ((procedure? target) - (procedure-documentation target)) + (cond ((> (string-length help-text) 0) + help-text) + ((procedure? procedure) + (let ((doc-text (procedure-documentation procedure))) + (and (string? doc-text) + (> (string-length doc-text) 0) + doc-text))) (else - target))) + help-text))) -(define* (display-help program-name target option-spec #:optional (commands '())) - (format #t "Usage: ~a [OPTIONS] +(define (get-help-text command) + "Return the title for the help message" + (let ((procedure (command-procedure command)) + (help-text (command-help-text command))) + (cond ((> (string-length help-text) 0) + help-text) + ((procedure? procedure) + (let ((doc-text (procedure-documentation procedure))) + (and (string? doc-text) + (> (string-length doc-text) 0) + doc-text))) + (else + help-text)))) + - ~a - -Options: -" program-name (get-title target)) - - (let* ((options (map (lambda (option) - (cons (format #f - "--~a~a~a" - (car option) - (let ((single-char - (option-property option 'single-char))) - (if single-char - (format #f ", -~a" single-char) - "")) - (let ((value - (not (option-property option 'flag)))) - (if value - (format #f " ~a" (get-type-description option)) - ""))) - (option-property option 'help ""))) - option-spec)) - (sep (+ 2 (apply max (map (lambda (option) - (string-length (car option))) - options))))) +(define (display-options options) + "Display options in tabular way" + (let ((sep (+ 2 (apply max (map (lambda (option) + (string-length (car option))) + options))))) (for-each (lambda (option) (format #t " ~a~v_~a~%" @@ -73,6 +72,50 @@ Options: options))) +(define* (display-help program-name command) + "Display help message" + + ;; Usage + (format #t "Usage: ~a [OPTIONS]" program-name) + (when (group? command) + (format #t " COMMAND [ARGS]...")) + (format #t "~%~%") + + ;; Title + (let ((title (get-help-text command))) + (when title + (format #t " ~a~%~%" title))) + + ;; Options + (format #t "Options:~%") + (let ((options (map (lambda (option) + (cons (format #f + "--~a~a~a" + (car option) + (let ((single-char + (option-property option 'single-char))) + (if single-char + (format #f ", -~a" single-char) + "")) + (let ((value + (not (option-property option 'flag)))) + (if value + (format #f " ~a" (get-type-description option)) + ""))) + (option-property option 'help ""))) + (command-option-spec command)))) + (display-options options)) + + ;; Commands + (when (group? command) + (format #t "~%Commands:~%") + (let ((options (map (lambda (command) + (cons (or (command-name command) "") + (or (get-help-text command) ""))) + (command-commands command)))) + (display-options options)))) + + (define (display-error wrong-option) (format #t "Usage: ~a [OPTIONS] Try '~a --help' for help. diff --git a/examples/hello.scm b/examples/hello.scm index 4f59ccc..b8f2eb6 100755 --- a/examples/hello.scm +++ b/examples/hello.scm @@ -25,13 +25,13 @@ (define hello (command - '((count (single-char #\c) (default 1) (help "Number of greetings.")) - (name (prompt "Your name") (help "The person to greet."))) - (lambda (count name) - "Simple program that greets NAME for a total of COUNT times." - (let loop ((times count)) - (cond ((> times 0) - (format #t "Hello ~a!~%" name) - (loop (- times 1)))))))) + #:option-spec '((count (single-char #\c) (default 1) (help "Number of greetings.")) + (name (prompt "Your name") (help "The person to greet."))) + #:procedure (lambda (count name) + "Simple program that greets NAME for a total of COUNT times." + (let loop ((times count)) + (cond ((> times 0) + (format #t "Hello ~a!~%" name) + (loop (- times 1)))))))) (hello (command-line)) diff --git a/examples/nested.scm b/examples/nested.scm index 023e1ef..414e589 100755 --- a/examples/nested.scm +++ b/examples/nested.scm @@ -25,21 +25,21 @@ (define initdb (command - '() - (lambda () - (format #t "Initialized the database")))) + #:name "initdb" + #:help "Init database." + #:procedure (lambda () + (format #t "Initialized the database")))) (define dropdb (command - '() - (lambda () - (format #t "Dropped the database")))) + #:name "dropdb" + #:help "Drop database." + #:procedure (lambda () + (format #t "Dropped the database")))) (define cli (group - '() - "Database Tools" - initdb - dropdb)) + #:help "Database Tools" + #:commands `(,initdb ,dropdb))) (cli (command-line)) -- 2.39.5