src/synopsis.lisp

   1 ;;; synopsis.lisp --- Synopsis management
   2
   3 ;; Copyright (C) 2010, 2011, 2012 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 *synopsis* nil "The current 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 allegro) (declare (ignore func elsewhere))
  56     (values))
  57   (:method :after (func (item item))
  58     "Mark TRAVERSABLE as traversed."
  59     #+(or ccl ecl clisp allegro) (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 "lisp-information"
 162                      ~"Display information about the underlying Lisp "
 163                      ~"implementation.")
 164                (flag "help" "Display Clon-specific help.")
 165                (group (:header "Option retrieval:")
 166                  (enum "error-handler"
 167                        "Set the option retrieval error handler.
 168 HDL can be `interactive', `quit' or `none'."
 169                        :argument-name "HDL"
 170                        :argument-type :optional
 171                        :enum '(:interactive :quit :none)
 172                        :fallback-value :none
 173                        :default-value :quit
 174                        :env-var "ERROR_HANDLER"))
 175                (group (:header "Help string output:")
 176                  (path "search-path"
 177                        "Set Clon's search path.
 178 If you don't want any search path at all, use this option with no argument."
 179                        :argument-type :optional
 180                        :type :directory-list
 181                        :fallback-value nil
 182                        ;; #### PORTME. I'm using Unix-like default for
 183                        ;; everything here, plus OSX specific values that I
 184                        ;; know of. Not sure about Windows or anything else.
 185                        :default-value
 186                        (let ((local-path '("share/clon/"))
 187                              (global-path '(#p"/usr/local/share/clon/"
 188                                             #p"/usr/share/clon/")))
 189                          (when (macosp)
 190                            (push "Library/Application Support/Clon/"
 191                                  local-path)
 192                            (push #p"/Library/Application Support/Clon/"
 193                                  global-path))
 194                          (push ".clon/" local-path)
 195                          (append
 196                           (mapcar
 197                            (lambda (subdir)
 198                              (merge-pathnames subdir
 199                                               (home-directory)))
 200                            local-path)
 201                           global-path))
 202                        :env-var "SEARCH_PATH")
 203                  (path "theme"
 204                        ~"Set Clon's output theme.
 205 If you don't want any theme at all, use this option with no argument. "
 206                        ~"Unless starting with /, ./ or ../, files are looked "
 207                        ~"for in the Clon search path. The cth extension can "
 208                        ~"be omitted."
 209                        :argument-name "FILE"
 210                        :argument-type :optional
 211                        :type :file
 212                        :fallback-value nil
 213                        :default-value (make-pathname :name "raw")
 214                        :env-var "THEME")
 215                  (lispobj "line-width"
 216                           ~"Set Clon's output line width.
 217 If not given, the value of the COLUMNS environment variable, the terminal "
 218                           ~"size, or a default of 80 columns will be used."
 219                           :argument-name "WIDTH"
 220                           :env-var "LINE_WIDTH"
 221                           :typespec '(integer 1))
 222                  (xswitch "highlight"
 223                           "Set Clon's output highlighting to on/off/auto.
 224 Auto (the default) means on for tty output and off otherwise."
 225                           :enum '(:auto)
 226                           :env-var "HIGHLIGHT"
 227                           :default-value :auto)))))
 228     (apply #'call-next-method synopsis
 229            :clon-options-group grp
 230            (nconc keys (list :item grp)))))
 231
 232 (defmethod initialize-instance :after
 233     ((synopsis synopsis) &key &aux potential-pack short-pack negated-pack)
 234   "Compute SYNOSPSIS's short and negated packs."
 235   (do-options (option synopsis)
 236     (let ((potential-pack-char (potential-pack-char option :as-string))
 237           (short-pack-char (short-pack-char option :as-string))
 238           (negated-pack-char (negated-pack-char option  :as-string)))
 239       (when potential-pack-char
 240         (setq potential-pack
 241               (concatenate 'string potential-pack potential-pack-char)))
 242       (when short-pack-char
 243         (setq short-pack
 244               (concatenate 'string short-pack short-pack-char)))
 245       (when negated-pack-char
 246         (setq negated-pack
 247               (concatenate 'string negated-pack negated-pack-char)))))
 248   (setf (slot-value synopsis 'potential-pack) potential-pack)
 249   (setf (slot-value synopsis 'short-pack) short-pack)
 250   (setf (slot-value synopsis 'negated-pack) negated-pack))
 251
 252 (defun make-synopsis (&rest keys &key postfix item (make-default t))
 253   "Make a new SYNOPSIS.
 254 - POSTFIX is a string to append to the program synopsis, in case it accepts a
 255 remainder.
 256 - If MAKE-DEFAULT, make the new synopsis the default one."
 257   (declare (ignore postfix item))
 258   (let ((synopsis (apply #'make-instance 'synopsis
 259                          (remove-keys keys :make-default))))
 260     (when make-default
 261       (setq *synopsis* synopsis))
 262     synopsis))
 263
 264 (defmacro defsynopsis ((&rest keys &key postfix make-default) &body forms)
 265   "Define a new synopsis."
 266   (declare (ignore postfix make-default))
 267   `(make-synopsis
 268     ,@keys
 269     ,@(loop :for form :in forms
 270             :nconc (list :item
 271                          (let ((item-name
 272                                  (when (consp form)
 273                                    (car (member (symbol-name (car form))
 274                                                 *item-names*
 275                                                 :test #'string=)))))
 276                            (if item-name
 277                                (list*
 278                                 (intern
 279                                  ;; #### NOTE: case portability
 280                                  (cond ((string= item-name (string :group))
 281                                         (string :defgroup))
 282                                        (t
 283                                         (format nil "~A~A"
 284                                           (string :make-)
 285                                           item-name)))
 286                                  :com.dvlsoft.clon)
 287                                 (cdr form))
 288                              form))))))
 289
 290
 291 ;;; synopsis.lisp ends here