src/group.lisp

   1 ;;; group.lisp --- Group management
   2
   3 ;; Copyright (C) 2010, 2011 Didier Verna
   4
   5 ;; Author:        Didier Verna <didier@lrde.epita.fr>
   6 ;; Maintainer:    Didier Verna <didier@lrde.epita.fr>
   7
   8 ;; This file is part of Clon.
   9
  10 ;; Permission to use, copy, modify, and distribute this software for any
  11 ;; purpose with or without fee is hereby granted, provided that the above
  12 ;; copyright notice and this permission notice appear in all copies.
  13
  14 ;; THIS SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  15 ;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  16 ;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  17 ;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  18 ;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  19 ;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  20 ;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  21
  22
  23 ;;; Commentary:
  24
  25 ;; Contents management by FCM version 0.1.
  26
  27
  28 ;;; Code:
  29
  30 (in-package :com.dvlsoft.clon)
  31 (in-readtable :com.dvlsoft.clon)
  32
  33
  34 ;; ==========================================================================
  35 ;; The Group class
  36 ;; ==========================================================================
  37
  38 (defclass group (container)
  39   ((header :documentation "The group's header."
  40            :initform nil
  41            :initarg :header
  42            :reader header))
  43   (:documentation "The GROUP class.
  44 This class groups other groups, options or strings together, effectively
  45 implementing hierarchical program command-line."))
  46
  47
  48 ;; ---------------------------
  49 ;; Help specification protocol
  50 ;; ---------------------------
  51
  52 (defmethod help-spec ((group group) &key)
  53   "Return GROUP's help specification."
  54   (accumulate (group)
  55     (accumulate (header)
  56       (header group))
  57     ;; This calls the container's method.
  58     (let ((items (call-next-method)))
  59       (when items
  60         (push 'items items)))))
  61
  62
  63
  64 ;; ==========================================================================
  65 ;; Group Instance Creation
  66 ;; ==========================================================================
  67
  68 (defun make-group (&rest keys &key header item hidden)
  69   "Make a new group."
  70   (declare (ignore header item hidden))
  71   (apply #'make-instance 'group keys))
  72
  73 (defmacro %defgroup (internalp (&rest keys &key header hidden) &body forms)
  74   "Define a new group."
  75   (declare (ignore header hidden))
  76   `(make-group ,@keys
  77     ,@(loop :for form :in forms
  78             :nconc (list :item
  79                          (let ((item-name
  80                                 (when (consp form)
  81                                   (car (member (symbol-name (car form))
  82                                                *item-names*
  83                                                :test #'string=)))))
  84                            (if item-name
  85                                (list* (intern
  86                                        (cond ((string= item-name "GROUP")
  87                                               "%DEFGROUP")
  88                                              (t
  89                                               (format nil
  90                                                   "MAKE-~:[~;INTERNAL-~]~A"
  91                                                 internalp item-name)))
  92                                        :com.dvlsoft.clon)
  93                                       (if (string= item-name "GROUP")
  94                                           (list* internalp (cdr form))
  95                                         (cdr form)))
  96                              form))))))
  97
  98 (defmacro defgroup ((&rest keys &key header hidden) &body forms)
  99   "Define a new group.
 100 KEYS are initargs to MAKE-GROUP (currently, only :header).
 101 Each form in FORMS will be treated as a new :item.
 102 The CAR of each form is the name of the operation to perform: TEXT, GROUP, or
 103 an option class name. The rest are the arguments to the MAKE-<OP> function or
 104 the DEFGROUP macro."
 105   (declare (ignore header hidden))
 106   `(%defgroup nil ,keys ,@forms))
 107
 108
 109 ;;; group.lisp ends here