X-Git-Url: https://git.jsancho.org/?p=guile-click.git;a=blobdiff_plain;f=click.scm;h=e8f8c09833acf6bb8abc67a22beb6d7141bd1731;hp=6a2d25323113da8c030307ab52452aff4d6e0ef0;hb=84da61950d4a4038f76fdb9f66e0bbbb71f75385;hpb=27b4e1f5bfac39323bdff089aac094b8e98b0258

diff --git a/click.scm b/click.scm
index 6a2d253..e8f8c09 100644
--- a/click.scm
+++ b/click.scm
@@ -19,19 +19,36 @@
 
 (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 display)
+  #:use-module (click help)
   #:use-module (click util)
   #:use-module (click value)
-  #:export (command))
+  #:export (command
+            group))
 
 
-(define (command option-spec 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))))))))
+(define* (command #:key (name #f) (option-spec '()) (help "") (procedure #f))
+  "Define a new command for the procedure"
+  (group #:name name
+         #:option-spec option-spec
+         #:help help
+         #:procedure procedure))
+
+
+(define* (group #:key (name #f) (option-spec '()) (help "") (procedure #f) (commands '()))
+  "Define a new group with a list of commands associated"
+  (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)))