From: Javier Sancho Date: Thu, 16 Sep 2021 16:33:27 +0000 (+0200) Subject: Groups support X-Git-Url: https://git.jsancho.org/?p=guile-click.git;a=commitdiff_plain;h=ebf74b7c3fda8ead57a398bb6a1555067150d06f Groups support --- diff --git a/Makefile.am b/Makefile.am index 0e24758..8a78d8d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -41,7 +41,7 @@ godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache SOURCES = \ click.scm \ click/constant.scm \ - click/display.scm \ + click/help.scm \ click/util.scm \ click/value.scm diff --git a/click.scm b/click.scm index 6a2d253..d2da6ac 100644 --- a/click.scm +++ b/click.scm @@ -20,18 +20,33 @@ (define-module (click) #:use-module (ice-9 getopt-long) #:use-module (click constant) - #:use-module (click display) + #:use-module (click help) #:use-module (click util) #:use-module (click value) - #:export (command)) + #:export (command + group)) (define (command option-spec procedure) + "Define a new command for the procedure" (lambda (args) - (with-fluids ((%program-name (car 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) - (display-help procedure click-option-spec) - (apply procedure (map cdr (get-values option-spec values)))))))) + (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))))))) + + +(define (group option-spec target . 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))))))) diff --git a/click/display.scm b/click/display.scm deleted file mode 100644 index 968a063..0000000 --- a/click/display.scm +++ /dev/null @@ -1,71 +0,0 @@ -;;; 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 display) - #:use-module (ice-9 format) - #:use-module (click util) - #:export (display-error - display-help)) - - -(define (get-type-description option) - "Return allowed type for the value in the option" - (assoc-ref (option-type option) 'description)) - -(define (display-help procedure option-spec) - (format #t "Usage: ~a [OPTIONS] - - ~a - -Options: -" (program-name) (procedure-documentation procedure)) - - (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))))) - (for-each (lambda (option) - (format #t - " ~a~v_~a~%" - (car option) - (- sep (string-length (car option))) - (cdr option))) - options))) - -(define (display-error wrong-option) - (format #t "Usage: ~a [OPTIONS] -Try '~a --help' for help. - -Error: No such option: ~a -" (program-name) (program-name) wrong-option)) diff --git a/click/help.scm b/click/help.scm new file mode 100644 index 0000000..f397031 --- /dev/null +++ b/click/help.scm @@ -0,0 +1,81 @@ +;;; 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 help) + #:use-module (ice-9 format) + #:use-module (click util) + #:export (display-error + display-help)) + + +(define (get-type-description option) + "Return allowed type for the value in the option" + (assoc-ref (option-type option) 'description)) + + +(define (get-title target) + "Return the title for the help message" + (cond ((procedure? target) + (procedure-documentation target)) + (else + target))) + + +(define* (display-help program-name target option-spec #:optional (commands '())) + (format #t "Usage: ~a [OPTIONS] + + ~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))))) + (for-each (lambda (option) + (format #t + " ~a~v_~a~%" + (car option) + (- sep (string-length (car option))) + (cdr option))) + options))) + + +(define (display-error wrong-option) + (format #t "Usage: ~a [OPTIONS] +Try '~a --help' for help. + +Error: No such option: ~a +" (program-name) (program-name) wrong-option)) diff --git a/click/util.scm b/click/util.scm index c3ac062..1699014 100644 --- a/click/util.scm +++ b/click/util.scm @@ -21,14 +21,7 @@ #:use-module (click constant) #:export (getopt-long-option-spec option-property - option-type - program-name - %program-name)) - - -(define %program-name (make-fluid "guile")) -(define (program-name) - (fluid-ref %program-name)) + option-type)) (define (getopt-long-option-spec option-spec) diff --git a/examples/nested.scm b/examples/nested.scm new file mode 100755 index 0000000..023e1ef --- /dev/null +++ b/examples/nested.scm @@ -0,0 +1,45 @@ +#!/usr/bin/guile-3.0 --no-auto-compile +-*- scheme -*- +!# +;;; 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 . + + +(use-modules (click)) + + +(define initdb + (command + '() + (lambda () + (format #t "Initialized the database")))) + +(define dropdb + (command + '() + (lambda () + (format #t "Dropped the database")))) + +(define cli + (group + '() + "Database Tools" + initdb + dropdb)) + +(cli (command-line))