src/synopsis.lisp

   1 ;;; synopsis.lisp --- Synopsis management
   2
   3 ;; Copyright (C) 2010, 2011, 2012, 2013 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                        ;; #### FIXME: this is wrong. If defsynopsis is used as
 187                        ;; a toplevel form, the fallback below will be
 188                        ;; computed at compile-time although it contains things
 189                        ;; that should be computed at run-time only (like the
 190                        ;; user home directory).
 191                        (let ((path '(#p"/usr/local/share/clon/"
 192                                      #p"/usr/share/clon/"))
 193                              (home-directory (home-directory)))
 194                          (when (macosp)
 195                            (push #p"/Library/Application Support/Clon/" path))
 196                          (when home-directory
 197                            (let ((local-path '("share/clon/")))
 198                              (when (macosp)
 199                                (push "Library/Application Support/Clon/"
 200                                      local-path))
 201                              (push ".clon/" local-path)
 202                              (setq path (append
 203                                          (mapcar
 204                                           (lambda (subdir)
 205                                             (merge-pathnames subdir
 206                                                              home-directory))
 207                                           local-path)
 208                                          path))))
 209                          path)
 210                        :env-var "SEARCH_PATH")
 211                  (path "theme"
 212                        ~"Set Clon's output theme.
 213 If you don't want any theme at all, use this option with no argument. "
 214                        ~"Unless starting with /, ./ or ../, files are looked "
 215                        ~"for in the Clon search path. The cth extension can "
 216                        ~"be omitted."
 217                        :argument-name "FILE"
 218                        :argument-type :optional
 219                        :type :file
 220                        :fallback-value nil
 221                        :default-value (make-pathname :name "raw")
 222                        :env-var "THEME")
 223                  (lispobj "line-width"
 224                           ~"Set Clon's output line width.
 225 If not given, the value of the COLUMNS environment variable, the terminal "
 226                           ~"size, or a default of 80 columns will be used."
 227                           :argument-name "WIDTH"
 228                           :env-var "LINE_WIDTH"
 229                           :typespec '(integer 1))
 230                  (xswitch "highlight"
 231                           "Set Clon's output highlighting to on/off/auto.
 232 Auto (the default) means on for tty output and off otherwise."
 233                           :enum '(:auto)
 234                           :env-var "HIGHLIGHT"
 235                           :default-value :auto)))))
 236     (apply #'call-next-method synopsis
 237            :clon-options-group grp
 238            (nconc keys (list :item grp)))))
 239
 240 (defmethod initialize-instance :after
 241     ((synopsis synopsis) &key &aux potential-pack short-pack negated-pack)
 242   "Compute SYNOSPSIS's short and negated packs."
 243   (do-options (option synopsis)
 244     (let ((potential-pack-char (potential-pack-char option :as-string))
 245           (short-pack-char (short-pack-char option :as-string))
 246           (negated-pack-char (negated-pack-char option  :as-string)))
 247       (when potential-pack-char
 248         (setq potential-pack
 249               (concatenate 'string potential-pack potential-pack-char)))
 250       (when short-pack-char
 251         (setq short-pack
 252               (concatenate 'string short-pack short-pack-char)))
 253       (when negated-pack-char
 254         (setq negated-pack
 255               (concatenate 'string negated-pack negated-pack-char)))))
 256   (setf (slot-value synopsis 'potential-pack) potential-pack)
 257   (setf (slot-value synopsis 'short-pack) short-pack)
 258   (setf (slot-value synopsis 'negated-pack) negated-pack))
 259
 260 (defun make-synopsis (&rest keys &key postfix item (make-default t))
 261   "Make a new SYNOPSIS.
 262 - POSTFIX is a string to append to the program synopsis, in case it accepts a
 263 remainder.
 264 - If MAKE-DEFAULT, make the new synopsis the default one."
 265   (declare (ignore postfix item))
 266   (let ((synopsis (apply #'make-instance 'synopsis
 267                          (remove-keys keys :make-default))))
 268     (when make-default
 269       (setq *synopsis* synopsis))
 270     synopsis))
 271
 272 (defmacro defsynopsis ((&rest keys &key postfix make-default) &body forms)
 273   "Define a new synopsis."
 274   (declare (ignore postfix make-default))
 275   `(make-synopsis
 276     ,@keys
 277     ,@(loop :for form :in forms
 278             :nconc (list :item
 279                          (let ((item-name
 280                                  (when (consp form)
 281                                    (car (member (symbol-name (car form))
 282                                                 *item-names*
 283                                                 :test #'string=)))))
 284                            (if item-name
 285                                (list*
 286                                 (intern
 287                                  ;; #### NOTE: case portability
 288                                  (cond ((string= item-name (string :group))
 289                                         (string :defgroup))
 290                                        (t
 291                                         (format nil "~A~A"
 292                                           (string :make-)
 293                                           item-name)))
 294                                  :com.dvlsoft.clon)
 295                                 (cdr form))
 296                              form))))))
 297
 298
 299 ;;; synopsis.lisp ends here