src/synopsis.lisp

   1 ;;; synopsis.lisp --- Synopsis 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 (defvar *default-synopsis* nil "The default synopsis.")
  35
  36
  37
  38 ;; ==========================================================================
  39 ;; The Option Mapping Protocol
  40 ;; ==========================================================================
  41
  42 ;; #### NOTE: there are two very good reasons for updating the traversal state
  43 ;; of item objects in an after method, as done below:
  44 ;; 1/ this is obviously the right thing to do,
  45 ;; 2/ moving it away from the primary method makes this primary method return
  46 ;;    the value of FUNC itself when FUNC is actually called. This is an
  47 ;;    important idiom because callers might want to rely on the return value
  48 ;;    of (the last computation of) mapoptions, especially when used through
  49 ;;    the DO-OPTIONS below. See for example the function SEARCH-OPTION-BY-NAME
  50 ;;    in context.lisp.
  51 (defgeneric mapoptions (func there)
  52   (:documentation "Map FUNC over all options in THERE.")
  53   (:method (func elsewhere)
  54     "Do nothing by default."
  55     #+(or ccl ecl clisp) (declare (ignore func elsewhere))
  56     (values))
  57   (:method :after (func (item item))
  58     "Mark TRAVERSABLE as traversed."
  59     #+(or ccl ecl clisp) (declare (ignore func))
  60     (setf (traversedp item) t))
  61   (:method (func (container container))
  62     "Map FUNC over all containers or options in CONTAINER."
  63     (unless (traversedp container)
  64       (dolist (item (items container))
  65         (mapoptions func item))))
  66   (:method (func (option option))
  67     "Call FUNC on OPTION."
  68     (unless (traversedp option)
  69       (funcall func option))))
  70
  71 (defmacro do-options ((opt there) &body body)
  72   "Execute BODY with OPT bound to every option in THERE."
  73   `(mapoptions (lambda (,opt) ,@body)
  74                (untraverse ,there)))
  75
  76
  77
  78 ;; ==========================================================================
  79 ;; The Synopsis Class
  80 ;; ==========================================================================
  81
  82 (defclass synopsis (container)
  83   ((postfix :documentation "A postfix to the program synopsis."
  84             :type (or null string)
  85             :initarg :postfix
  86             :initform nil
  87             :reader postfix)
  88    (short-pack :documentation "The short pack string."
  89                :type (or null string)
  90                :reader short-pack)
  91    (negated-pack :documentation "The negated pack string."
  92                  :type (or null string)
  93                  :reader negated-pack)
  94    (potential-pack :documentation "The potential pack string."
  95                    :type (or null string)
  96                    :reader potential-pack)
  97    (clon-options-group :documentation "The Clon options group."
  98                        :type group
  99                        :initarg :clon-options-group
 100                        :reader clon-options-group))
 101   (:documentation "The SYNOPSIS class.
 102 This class handles the description of the program's command-line options."))
 103
 104
 105 ;; ---------------------------
 106 ;; Help specification protocol
 107 ;; ---------------------------
 108
 109 (defmethod help-spec ((synopsis synopsis) &key program)
 110   "Return SYNOPSIS's help specification."
 111   (list* (accumulate (synopsis)
 112            '(header "Usage:")
 113            `(program ,program)
 114            (accumulate (short-pack)
 115              (when (short-pack synopsis)
 116                (format nil "[-~A]" (short-pack synopsis))))
 117            (accumulate (negated-pack)
 118              (when (negated-pack synopsis)
 119                (format nil "[+~A]" (negated-pack synopsis))))
 120            '(options "[OPTIONS]")
 121            (accumulate (postfix)
 122              (postfix synopsis)))
 123          ;; This calls the container's method.
 124          (call-next-method)))
 125
 126
 127
 128 ;; ==========================================================================
 129 ;; The Potential Pack Protocol
 130 ;; ==========================================================================
 131
 132 ;; #### NOTE: a generic function is a bit overkill here, because its use is
 133 ;; only to provide a convenience wrapper for contexts.
 134 (defgeneric potential-pack-p (pack there)
 135   (:documentation "Return t if PACK is a potential pack in THERE.")
 136   (:method (pack (synopsis synopsis))
 137     "Return t if PACK is a potential pack for SYNOPSIS."
 138     ;; #### NOTE: if there's no potential pack in SYNOPSIS, the call to
 139     ;; STRING-LEFT-TRIM gets a nil CHAR-BAG which is ok and gives the expected
 140     ;; result.
 141     (zerop (length (string-left-trim (potential-pack synopsis) pack)))))
 142
 143
 144
 145 ;; ==========================================================================
 146 ;; Synopsis Instance Creation
 147 ;; ==========================================================================
 148
 149 (defmethod initialize-instance :around ((synopsis synopsis) &rest keys)
 150   "Prepare Clon specific options."
 151   (let ((grp (%defgroup t (:header "Clon specific options:" :hidden t)
 152                (flag "banner" "Display the full Clon banner.")
 153                (enum "version"
 154                      "Display Clon's version number.
 155 FMT can be `number', `short' or `long'."
 156                      :argument-name "FMT"
 157                      :argument-type :optional
 158                      :enum '(:number :short :long)
 159                      :fallback-value :long
 160                      #|:env-var "VERSION_FORMAT"|#)
 161                (flag "help" "Display Clon-specific help.")
 162                (group (:header "Option retrieval:")
 163                  (enum "error-handler"
 164                        "Set the option retrieval error handler.
 165 HDL can be `interactive', `quit' or `none'."
 166                        :argument-name "HDL"
 167                        :argument-type :optional
 168                        :enum '(:interactive :quit :none)
 169                        :fallback-value :none
 170                        :default-value :quit
 171                        :env-var "ERROR_HANDLER"))
 172                (group (:header "Help string output:")
 173                  (path "search-path"
 174                        "Set Clon's search path.
 175 If you don't want any search path at all, use this option with no argument."
 176                        :argument-type :optional
 177                        :type :directory-list
 178                        :fallback-value nil
 179                        ;; #### PORTME. I'm using Unix-like default for
 180                        ;; everything here, plus OSX specific values that I
 181                        ;; know of. Not sure about Windows or anything else.
 182                        :default-value
 183                        (let ((local-path '("share/clon/"))
 184                              (global-path '(#p"/usr/local/share/clon/"
 185                                             #p"/usr/share/clon/")))
 186                          (when (macosp)
 187                            (push "Library/Application Support/Clon/"
 188                                  local-path)
 189                            (push #p"/Library/Application Support/Clon/"
 190                                  global-path))
 191                          (push ".clon/" local-path)
 192                          (append
 193                           (mapcar
 194                            (lambda (subdir)
 195                              (merge-pathnames subdir
 196                                               (home-directory)))
 197                            local-path)
 198                           global-path))
 199                        :env-var "SEARCH_PATH")
 200                  (path "theme"
 201                        ~"Set Clon's output theme.
 202 If you don't want any theme at all, use this option with no argument. "
 203                        ~"Unless starting with /, ./ or ../, files are looked "
 204                        ~"for in the Clon search path. The cth extension can "
 205                        ~"be omitted."
 206                        :argument-name "FILE"
 207                        :argument-type :optional
 208                        :type :file
 209                        :fallback-value nil
 210                        :default-value (make-pathname :name "raw")
 211                        :env-var "THEME")
 212                  (lispobj "line-width"
 213                           ~"Set Clon's output line width.
 214 If not given, the value of the COLUMNS environment variable, the terminal "
 215                           ~"size, or a default of 80 columns will be used."
 216                           :argument-name "WIDTH"
 217                           :env-var "LINE_WIDTH"
 218                           :typespec '(integer 1))
 219                  (xswitch "highlight"
 220                           "Set Clon's output highlighting to on/off/auto.
 221 Auto (the default) means on for tty output and off otherwise."
 222                           :enum '(:auto)
 223                           :env-var "HIGHLIGHT"
 224                           :default-value :auto)))))
 225     (apply #'call-next-method synopsis
 226            :clon-options-group grp
 227            (nconc keys (list :item grp)))))
 228
 229 (defmethod initialize-instance :after
 230     ((synopsis synopsis) &key &aux potential-pack short-pack negated-pack)
 231   "Compute SYNOSPSIS's short and negated packs."
 232   (do-options (option synopsis)
 233     (let ((potential-pack-char (potential-pack-char option :as-string))
 234           (short-pack-char (short-pack-char option :as-string))
 235           (negated-pack-char (negated-pack-char option  :as-string)))
 236       (when potential-pack-char
 237         (setq potential-pack
 238               (concatenate 'string potential-pack potential-pack-char)))
 239       (when short-pack-char
 240         (setq short-pack
 241               (concatenate 'string short-pack short-pack-char)))
 242       (when negated-pack-char
 243         (setq negated-pack
 244               (concatenate 'string negated-pack negated-pack-char)))))
 245   (setf (slot-value synopsis 'potential-pack) potential-pack)
 246   (setf (slot-value synopsis 'short-pack) short-pack)
 247   (setf (slot-value synopsis 'negated-pack) negated-pack))
 248
 249 (defun make-synopsis (&rest keys &key postfix item (make-default t))
 250   "Make a new SYNOPSIS.
 251 - POSTFIX is a string to append to the program synopsis, in case it accepts a
 252 remainder.
 253 - If MAKE-DEFAULT, make the new synopsis the default one."
 254   (declare (ignore postfix item))
 255   (let ((synopsis (apply #'make-instance 'synopsis
 256                          (remove-keys keys :make-default))))
 257     (when make-default
 258       (setq *default-synopsis* synopsis))
 259     synopsis))
 260
 261 (defmacro defsynopsis ((&rest keys &key postfix make-default) &body forms)
 262   "Define a new synopsis."
 263   (declare (ignore postfix make-default))
 264   `(make-synopsis
 265     ,@keys
 266     ,@(loop :for form :in forms
 267             :nconc (list :item
 268                          (let ((item-name
 269                                  (when (consp form)
 270                                    (car (member (symbol-name (car form))
 271                                                 *item-names*
 272                                                 :test #'string=)))))
 273                            (if item-name
 274                                (list* (intern
 275                                        (cond ((string= item-name "GROUP")
 276                                               "DEFGROUP")
 277                                              (t
 278                                               (format nil "MAKE-~A"
 279                                                 item-name)))
 280                                        :com.dvlsoft.clon)
 281                                       (cdr form))
 282                              form))))))
 283
 284
 285 ;;; synopsis.lisp ends here