code.consxy.com Git - opera/blob - src/main/opera.lisp

   1 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
   2 (defpackage #:opera
   3  (:use :common-lisp)
   4  (:export #:process-arguments #:usage
   5   #:invalid-option-definition #:invalid-option-reason #:invalid-option-option
   6   #:option-present #:option-argument #:option-arguments))
   7
   8 ; - :name - name returned
   9 ; - :short - single character, yes!
  10 ; - :long - long form, double yes
  11 ; - :takes-argument - t/nil, defaulting to nil, if t, consumes the next thign and sets it as the argument
  12 ; - :description - desc of option, the formatting of which has to be done by the software writer
  13 ; - :variable-name - for auto printing help, if ommitted, not used
  14 ; - :required - for auto printing help, if included, the brackets are omitted
  15 ;   - probably doesn't make much sense for non positional options (or else, why are they options?)
  16 ; - :positional - for auto printing help, for arguments that aren't related to options
  17
  18
  19 (in-package #:opera)
  20
  21 (define-condition invalid-option-definition nil
  22  ((reason :initarg :reason :reader invalid-option-reason)
  23   (option :initarg :option :reader invalid-option-option))
  24  (:report
  25   (lambda (c str)
  26    (format str "Invalid option definition (~A) for option (~A)" (invalid-option-reason c) (invalid-option-option c)))))
  27
  28 ; validate that the things we need
  29 (defun validate-option (option &optional for-usage)
  30  (labels
  31   ((invalid (reason) (error (make-instance 'invalid-option-definition :reason reason :option option)))
  32    (option-val (key)
  33     (handler-case
  34      (getf option key)
  35      (error (e) (error (make-instance 'invalid-option-definition :reason e :option e))))))
  36   (cond
  37    ((not (list option)) (invalid "Option is not a list"))
  38    ((and (not (option-val :name)) (not (option-val :positional))) (invalid ":name required"))
  39    ((and (not (option-val :positional)) (not (option-val :short)) (not (option-val :long))) (invalid ":long or :short required"))
  40    ((and for-usage (not (option-val :description))) (invalid ":description required for usage"))
  41    ((and for-usage (option-val :takes-argument) (not (option-val :variable-name)))
  42     (invalid ":variable-name required for usage when :takes-argument present")))))
  43
  44 (defun starts-with-hyphen (arg)
  45  (and (< 0 (length arg)) (eql #\- (aref arg 0))))
  46
  47 (defun option-matching-arg (options arg)
  48  (when arg
  49   (find-if
  50    (lambda (option)
  51     (or
  52      (and (getf option :short) (string= arg (format nil "-~A" (getf option :short))))
  53      (and (getf option :long) (string= arg (format nil "--~A" (getf option :long))))))
  54    options)))
  55
  56 (defun process (options args)
  57  (let
  58   ((option (option-matching-arg options (car args))))
  59   (cond
  60    ((and (not option) (starts-with-hyphen (car args))) (values nil args :unknown-option))
  61    ((not option) (values nil args))
  62    ((and (getf option :takes-argument) (= 1 (length args)))
  63     (values nil args :required-argument-missing))
  64    ((getf option :takes-argument)
  65     (multiple-value-bind (result remaining-args error) (process options (cddr args))
  66      (values
  67       (cons (list (getf option :name) (cadr args)) result)
  68       remaining-args
  69       error)))
  70    (t
  71     (multiple-value-bind (result remaining-args error) (process options (cdr args))
  72      (values
  73       (cons (list (getf option :name)) result)
  74       remaining-args
  75       error))))))
  76
  77 (defun process-arguments (options args)
  78  (mapcar #'validate-option options)
  79  (process options args))
  80
  81 (defun create-usage-line (command options line-width)
  82  (let*
  83   ((command-width (+ (length "usage: ") (length command)))
  84    (width-available (- line-width command-width)))
  85   (when (> 0 width-available)
  86    (error "Command ~A too long for line-width ~A" command line-width))
  87   (labels
  88    ((process-options (remaining-options &optional current-strings)
  89      (if (not remaining-options)
  90       (format nil
  91        ; Then 1+ is for the space after the command
  92        (format nil "~~A~~{~~%~~,,~A@A~~}" (1+ command-width))
  93        (car (reverse current-strings))
  94        (cdr (reverse current-strings)))
  95       (let*
  96        ((option (car remaining-options))
  97         (option-string
  98          (format nil "~A~A~A~A~A~A~A~A"
  99           (if (getf option :required) "" "[")
 100           (if (getf option :short) (format nil "-~A" (getf option :short)) "")
 101           (if (and (getf option :short) (getf option :takes-argument))
 102            (format nil " ~A" (getf option :variable-name))
 103            "")
 104           (if (and (getf option :short) (getf option :long)) " | " "")
 105           (if (getf option :long) (format nil "--~A" (getf option :long)) "")
 106           (if (and (getf option :long) (getf option :takes-argument))
 107            (format nil " ~A" (getf option :variable-name))
 108            "")
 109           (or (getf option :positional) "")
 110           (if (getf option :required) "" "]"))))
 111        (when (> (length option-string) width-available)
 112         (error "Option ~A too long for line-width ~A" option-string line-width))
 113        (cond
 114         ((not current-strings) (process-options (cdr remaining-options) (list option-string)))
 115         ((< width-available (+ 1 (length option-string) (length (car current-strings))))
 116          (process-options (cdr remaining-options) (cons option-string current-strings)))
 117         (t
 118          (process-options
 119           (cdr remaining-options)
 120           (cons
 121            (format nil "~A ~A" (car current-strings) option-string)
 122            (cdr current-strings)))))))))
 123   (format nil "usage: ~A ~A" command (process-options options)))))
 124
 125 (defun option-string-for-long-description (option)
 126  (format nil "~A~A~A~A~A~A"
 127   (if (getf option :short) (format nil "-~A" (getf option :short)) "")
 128   (if (and (getf option :short) (getf option :takes-argument)) (format nil " ~A" (getf option :variable-name)) "")
 129   (if (and (getf option :short) (getf option :long)) ", " "")
 130   (if (getf option :long) (format nil "--~A" (getf option :long)) "")
 131   (if (and (getf option :long) (getf option :takes-argument)) (format nil " ~A" (getf option :variable-name)) "")
 132   (or (getf option :positional) "")))
 133
 134 (defun split-text (remaining-text width)
 135  (if
 136   (<= (length remaining-text) width)
 137   (list remaining-text)
 138   (let*
 139    ((cr-point (position #\Newline remaining-text :end width))
 140     (space-point (position #\Space remaining-text :from-end t :end width))
 141     (split-point (or cr-point space-point)))
 142    (when (not split-point)
 143     (error "Couldn't split ~A due to word length" remaining-text))
 144    (cons
 145     (subseq remaining-text 0 split-point)
 146     (split-text (subseq remaining-text (1+ split-point)) width)))))
 147
 148 (defun option-to-long-description (option left-column-width max-width)
 149  (let
 150   ((description (getf option :description))
 151    (available-width (- max-width left-column-width 4)))
 152   (let
 153    ((split-description (split-text description available-width))
 154     (option-string (option-string-for-long-description option)))
 155    (format nil
 156     (format nil "  ~~A~~,,~A@A~~%~~{~~,,~A@A~~%~~}"
 157      (+ 2 (- left-column-width (length option-string)))
 158      (+ 4 left-column-width))
 159     option-string
 160     (car split-description)
 161     (cdr split-description)))))
 162
 163 (defun options-to-description-string (options max-width)
 164  (let
 165   ((left-column-width (apply #'max (mapcar #'length (mapcar #'option-string-for-long-description options)))))
 166   (format nil "~%Options:~{~%~A~}" (mapcar (lambda (option) (option-to-long-description option left-column-width max-width)) options))))
 167
 168 (defun reformat-description (description max-width)
 169  (if
 170   (zerop (length description))
 171   ""
 172   (format nil "~{~A~%~}"
 173    (split-text description max-width))))
 174
 175 ; Just build out a reasonable default usage
 176 ;
 177 ; use sed --help as a base, that's reasonable enough
 178 ; split on whitespace, which is also reasonable enough
 179 (defun usage (command options &optional (description "") (line-width 102))
 180  (mapcar (lambda (opt) (validate-option opt t)) options)
 181  (format nil "~A~%~A~A~A"
 182   (create-usage-line command options line-width)
 183   (options-to-description-string options line-width)
 184   (if (zerop (length description)) "" (format nil "~%"))
 185   (reformat-description description line-width)))
 186
 187 ; helper functions
 188 (defun option-present (option-name parsed-options)
 189  (find option-name parsed-options :key #'car))
 190
 191 (defun option-argument (option-name parsed-options &optional default)
 192  (if
 193   (option-present option-name parsed-options)
 194   (cadr (assoc option-name parsed-options))
 195   default))
 196
 197 (defun option-arguments (option-name parsed-options)
 198  (mapcar #'cadr (remove option-name parsed-options :key #'car :test-not #'eql)))