scripts/optargs.scm - main - punzik/simbench

scripts/optargs.scm
66 строк2 KB
Nikolay Puzanov
Add sources
11 июн 2023, 16:15
11 июн 2023, 16:15686d12b
(define-module (optargs))

(import (srfi srfi-1)
        (srfi srfi-11)
        (srfi srfi-37))

(export parse-opts
        option-get)

;;;
;;; TODO: Write docs
;;;
(define (option-get opts name)
  (let ((opt (assoc name opts)))
    (if opt
        (cdr opt)
        #f)))

(define (option-set opts name value)
  (if (assoc name opts)
      (map (lambda (opt)
             (if (equal? (car opt) name)
                 (cons name value)
                 opt))
           opts)
      (alist-cons name value opts)))

(define (option-add opts name value)
  (if (assoc name opts)
      (option-set opts name
                  (cons value
                        (option-get opts name)))
      (alist-cons name `(,value) opts)))

;;; opt-spec - '(("option" #\o) [none | required | optional | multiple])
(define (parse-opts args . opt-spec)
  (args-fold
   ;; args
   args
   ;; options
   (map (lambda (spec)
          (let* ((names (list-ref spec 0))
                 (type (list-ref spec 1))
                 (name (car names))
                 (req? (eq? type 'required))
                 (opt? (eq? type 'optional))
                 (many? (eq? type 'multiple)))
            (option names (or many? req?) opt?
                    (if many?
                        (lambda (opt nm arg opts rest error)
                          (values (if arg
                                      (option-add opts name arg)
                                      opts)
                                  rest
                                  error))
                        (lambda (opt nm arg opts rest error)
                          (values (option-set opts name (if arg arg #t)) rest error))))))
        opt-spec)
   ;; unrecognized options
   (lambda (opt name arg opts rest error)
     (values opts rest name))
   ;; operands
   (lambda (operand opts rest error)
     (values opts (cons operand rest) error))
   ;; seeds
   '() '() #f))