Changeset 14502 in project


Ignore:
Timestamp:
04/29/09 00:12:27 (11 years ago)
Author:
Ivan Raikov
Message:

args ported to Chicken 4

Location:
release/4/args
Files:
2 deleted
3 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/args/args.meta

    r4616 r14502  
    99 (license "BSD")
    1010 (category misc)
    11  (files "args-support.scm" "args.scm" "args.setup" "args.html"))
     11 (files "args.scm" "args.setup" "args.html"))
  • release/4/args/args.scm

    r11245 r14502  
    11
    2 ;; $Revision: 1.4 $ $Date: 2005/06/14 21:05:45 $
    3 (require-extension srfi-37)
    4 
    5 ;;; macro: (args:make-option (OPTION-NAME ...) ARG-DATA [BODY])
    6 
     2
     3(module args
     4       
     5        (;; Option lists
     6         args:parse
     7         args:help-options
     8         args:ignore-unrecognized-options
     9         args:accept-unrecognized-options
     10         make-args:option
     11         ;; Usage printing
     12         args:usage
     13         args:width
     14         args:separator
     15         args:indent
     16
     17         args:make-option args:make-operand-proc)
     18
     19        (import scheme chicken extras )
     20
     21        (require-extension srfi-1 srfi-13 srfi-37)
     22
     23
     24;;; macro: (args:make-option (OPTION-NAME ...) ARG-TYPE [BODY])
     25;; Make an args:option record, suitable for passing to args:parse.
     26;;
    727;; OPTION-NAME ... is a sequence of short or long option names.  They must be literal
    828;; symbols; single-character symbols become short options, and longer symbols become
     
    2747;; and ARG (argument value or #f).
    2848
    29 (define-macro (args:make-option names arg-data docstring . body)
    30   (let* ((srfi37-names (map (lambda (name)
    31                               (let ((str (symbol->string name)))
    32                                 (if (= (string-length str) 1)
    33                                     (string-ref str 0)
    34                                     str)))
    35                             names))
    36          (arg-name (if (pair? arg-data) (cadr arg-data) "ARG"))
    37          (arg-type (if (pair? arg-data) (car arg-data) arg-data)))
    38     `(make-args:option
    39       (option ',srfi37-names
    40               ,(eq? arg-type #:required)
    41               ,(eq? arg-type #:optional)
    42               (lambda (opt name arg options operands)
    43                 (if (and (not arg) (eq? ,arg-type #:required))
    44                     (begin
    45                       (fprintf (current-error-port)
    46                                "~A: option ~A requires an argument\n"
    47                                (car (argv)) name)
    48                       (values options operands))
    49                     (begin
    50                       ,@body
    51                       (values (append (map (lambda (n) (cons n arg))
    52                                            ',names)
    53                                       options)
    54                               operands)))))
    55                 ;;(values (cons (cons name arg) options) operands)))
    56       ,arg-name
    57       ,docstring)))
     49(define-record args:option option arg-name docstring)
     50
     51;;; procedure: (args:parse ARGS OPTIONS-LIST [OPTIONALS])
     52;; [chicken-specific dependencies: FPRINTF; GET-KEYWORD; ARGV]
     53
     54;; Parse ARGS, a list of command-line arguments given as strings,
     55;; and return two values: an alist of option names (symbols) and their values,
     56;; and a list of operands (non-option arguments).
     57
     58;; Operands are returned in order, but options are returned in reverse order.
     59;; Duplicate options are retained in the options alist, so this lets ASSQ
     60;; find the -last- occurrence of any duplicate option on the command line.
     61;; A (name . value) pair is added for each alias of every option found,
     62;; so any alias is a valid lookup key.
     63
     64;; OPTIONS-LIST is a list of accepted options, each created by
     65;; args:make-option.
     66;;
     67;; OPTIONALS is an optional sequence of keywords and values:
     68;;   #:operand-proc PROCEDURE   -- calls PROCEDURE for each operand
     69;;                                 with arguments OPERAND OPTIONS OPERANDS
     70;;   #:unrecognized-proc PROCEDURE -- calls PROCEDURE for each unrecognized option
     71;;                                    with arguments OPTION NAME ARG OPTIONS OPERANDS
     72;; The default operand-proc is a no-op, and the default unrecognized-proc
     73;; issues an error message and calls the help option's processor.
     74;; See the args-fold documentation for usage information and an explanation
     75;; of the procedure arguments; OPTIONS and OPERANDS are seed values.
     76
     77;; Two prefabricated unrecognized-procs are provided:
     78;;    args:ignore-unrecognized-options
     79;;    args:accept-unrecognized-options
     80
     81(define (find-named-option name opts)
     82  (find (lambda (o)
     83          (member name (option-names (args:option-option o))))
     84        opts))
     85
     86(define (find-help-option opts)
     87  (any (lambda (n) (find-named-option n opts))
     88       (args:help-options)))
     89
    5890 
    5991;;; macro: (args:make-operand-proc [BODY])
     
    6496;; and OPTIONS and OPERANDS are SEEDS (as in args-fold) and should not be modified.
    6597;; Also wraps BODY in code that adds the operand to the final operand list (seed).
    66 (define-macro (args:make-operand-proc . body)
    67   `(lambda (operand options operands)
    68      ,@body
    69      (values options (cons operand operands))))
     98
     99(define-syntax args:make-operand-proc
     100  (syntax-rules ()
     101    ((_ body ...)
     102     (lambda (operand options operands)
     103       body ...
     104       (values options (cons operand operands))))))
     105
     106;;; parameter: args:help-options
     107;; List of option names (strings or single characters, as in SRFI 37)
     108;; to be considered 'help' options, in order of preference.  args:parse
     109;; uses this to select a help option from the option list it is passed.
     110;; This is currently used only for unrecognized options, for which the
     111;; help option is automatically invoked.
     112
     113(define args:help-options
     114  (make-parameter '("help" #\h #\?)))
     115
     116(define (args:parse args options-list . optionals)
     117  (let ((help-option (find-help-option options-list)))
     118    (receive (options operands)
     119        (args-fold args
     120                   (map (lambda (x) (args:option-option x))
     121                        options-list)
     122                   (get-keyword #:unrecognized-proc optionals
     123                                (lambda ()  ; thunk
     124                                  ;; Default: print unrecognized option and execute help procedure,
     125                                  ;; if a help option was provided.
     126                                  (lambda (opt name arg options operands)
     127                                    (fprintf (current-error-port)
     128                                             "~A: unrecognized option: ~A\n"
     129                                             (car (argv)) name)
     130                                    (if help-option
     131                                        ((option-processor (args:option-option help-option))
     132                                         opt name arg options operands)
     133                                        (exit 1)))))
     134                   ;; modify the operands list for operands
     135                   (get-keyword #:operand-proc optionals
     136                                (lambda () (args:make-operand-proc))) ;; default
     137                   '()     ;; seed 1: options alist
     138                   '())    ;; seed 2: operands list
     139      (values options (reverse operands)))))
     140
     141;;; Prefabbed unrecognized option procedures
     142;; Suitable for use as the #:unrecognized-proc in args:parse.
     143
     144;; Silently ignore unrecognized options, and omit from the options alist.
     145(define args:ignore-unrecognized-options
     146  (lambda (o n x options operands)
     147    (values options operands)))
     148
     149;; Silently add unrecognized options to the options alist.
     150(define args:accept-unrecognized-options
     151  (lambda (o n x options operands)
     152    (values (cons (cons (string->symbol (if (char? n) (string n) n))
     153                        x)
     154                  options)
     155            operands)))
     156
     157;;; Usage handling
     158
     159;; Change #\c => "-c" and "cookie" to "--cookie".
     160(define (dashify x)
     161  (if (char? x)
     162      (string #\- x)
     163      (string-append "--" x)))
     164 
     165;; O is an args:option
     166;; Join together option names in O with commas, and append the
     167;; argument type and name
     168(define (spaces n)
     169  (let loop ((ls '()) (n n))
     170    (if (<= n 0)
     171        (list->string ls)
     172        (loop (cons #\space ls)
     173              (- n 1)))))
     174
     175(define (commify o)   ;; more at home in Stalin?
     176  (let ((arg-type (lambda (args:o o-name)
     177                    (let* ((arg-name (args:option-arg-name args:o))
     178                           (o (args:option-option args:o)))
     179                      (cond ((option-required-arg? o)
     180                             (string-append (if (char? o-name)
     181                                                " " "=")
     182                                            arg-name))
     183                            ((option-optional-arg? o)
     184                             (string-append (if (char? o-name)
     185                                                " [" "[=")
     186                                            arg-name "]"))
     187                            (else ""))))))
     188
     189    (let loop ((accum #f)
     190               (names (option-names (args:option-option o))))
     191      (if (null? names)
     192          accum
     193          (let* ((name (car names))
     194                 (may-be-arg
     195                  (if (null? (cdr names))
     196                      (arg-type o name)
     197                      "")))
     198            (loop (string-append (or accum
     199                                     ;; Must deal with first one specially
     200                                     (if (string? name)
     201                                         (spaces (+ 2 (string-length (args:separator))))
     202                                         ""))
     203                                 (if accum (args:separator) "")
     204                                 (dashify name) may-be-arg)
     205                  (cdr names)))))))
     206
     207;;; parameter: args:width
     208;; We don't auto-format the left column (the option keys) based on the length of the longest
     209;; option, but you can override it manually.
     210;;
     211;; Example: (parameterize ((args:width 40)) (args:usage opts))
     212(define args:width (make-parameter 25))
     213;;; parameter: args:separator
     214;; The separator used between options.  Default: ", "
     215;; Example: (parameterize ((args:separator " ")) (args:usage opts))
     216(define args:separator (make-parameter ", "))
     217(define args:indent (make-parameter 1))
     218
     219;; O is an args:option
     220(define (usage-line o)
     221  (let ((option-string (commify o)))
     222    (string-append (spaces (args:indent))
     223                   (string-pad-right option-string (args:width))
     224                   (args:option-docstring o) "\n")))
     225
     226;;; procedure: (args:usage OPTION-LIST)
     227;; Generate a formatted list of options from OPTION-LIST,
     228;; and return a string suitable for embedding into help text.
     229;; The single string consists of multiple lines, with a newline
     230;; at the end of each line.  Thus, a typical use would be
     231;; (print (args:usage opts)).
     232(define (args:usage opts)
     233  (apply string-append (map usage-line opts)))
     234
     235
     236;;; macro: (args:make-option (OPTION-NAME ...) ARG-DATA [BODY])
     237
     238;; OPTION-NAME ... is a sequence of short or long option names.  They must be literal
     239;; symbols; single-character symbols become short options, and longer symbols become
     240;; long options.  So (args:make-option (c cookie) <...>) specifies a short option -c
     241;; and long option --cookie.  Underneath, (c cookie) becomes '(#\c "cookie"), as
     242;; expected by SRFI 37's OPTION.
     243;;
     244;; ARG-DATA is either a pair (ARG-TYPE ARG-NAME) or a plain keyword ARG-TYPE.
     245;; ARG-TYPE is a keyword that specifies whether the option takes an argument:
     246;;    #:required   Argument is required
     247;;    #:optional   Argument is optional
     248;;    #:none       Does not take an argument (actually, any other value than
     249;;                 #:required or #:optional is interpreted as #:none)
     250;; ARG-NAME, if provided, is a string specifying the name of the argument.
     251;; This name is used in the help text produced by args:usage.
     252;;
     253;; BODY is an optional sequence of statements executed when this option is encountered.
     254;; Behind the scenes, BODY is wrapped in code which adds the current option and its
     255;; argument to the final options alist.  So, simply leave BODY blank and options
     256;; will be collected for you.  BODY is an option-processor as defined in SRFI 37,
     257;; and has access to the variables OPT (the current #<option>), NAME (the option name)
     258;; and ARG (argument value or #f).
     259
     260(define-syntax args:make-option
     261  (lambda (x r c)
     262    (let ((names     (cadr x))
     263          (arg-data  (caddr x))
     264          (docstring (cadddr x))
     265          (body      (cddddr x))
     266          (%lambda  (r 'lambda))
     267          (%begin   (r 'begin))
     268          (%values  (r 'values))
     269          (%if      (r 'if))
     270          (%and     (r 'and))
     271          (%not      (r 'not))
     272          (%eq?     (r 'eq?))
     273          (%car      (r 'car))
     274          (%cons     (r 'cons))
     275          (%append   (r 'append))
     276          (%map     (r 'map))
     277          (argv     (r 'argv))
     278          (fprintf  (r 'fprintf))
     279          (current-error-port    (r 'current-error-port))
     280          (option  (r 'option))
     281          (make-args:option  (r 'make-args:option))
     282          )
     283
     284      (let* ((srfi37-names (map (lambda (name)
     285                                  (let ((str (symbol->string name)))
     286                                    (if (= (string-length str) 1)
     287                                        (string-ref str 0)
     288                                        str)))
     289                                names))
     290             (arg-name (if (pair? arg-data) (cadr arg-data) "ARG"))
     291             (arg-type (if (pair? arg-data) (car arg-data) arg-data)))
     292
     293        `(,make-args:option
     294          (,option ',srfi37-names
     295                  ,(eq? arg-type #:required)
     296                  ,(eq? arg-type #:optional)
     297                  (,%lambda (opt name arg options operands)
     298                    (,%if (,%and (,%not arg) (,%eq? ,arg-type #:required))
     299                        (,%begin
     300                          (,fprintf (,current-error-port)
     301                                   "~A: option ~A requires an argument\n"
     302                                   (,%car (,argv)) name)
     303                          (,%values options operands))
     304                        (,%begin
     305                          ,@body
     306                          (,%values (,%append (,%map (,%lambda (n) (,%cons n arg))
     307                                                     ',names)
     308                                              options)
     309                                    operands)))))
     310          ;;(values (cons (cons name arg) options) operands)))
     311          ,arg-name
     312          ,docstring)))))
     313
     314)
  • release/4/args/args.setup

    r11245 r14502  
    1 (define has-exports? (string>=? (chicken-version) "2.310"))
     1;;; -*- Hen -*-
    22
    3 (compile -s -O2 -d1
    4         ,@(if has-exports? '(-check-imports -emit-exports args.exports) '())
    5         args-support.scm)
     3(define (dynld-name fn)         
     4  (make-pathname #f fn ##sys#load-dynamic-extension))   
    65
    7 (install-extension 'args
    8         `("args.scm" "args-support.so" )
    9         `((syntax)
    10                 (version 1.3)
    11                 (documentation "args.html")
    12                 ,@(if has-exports? `((exports "args.exports")) '())
    13                 (require-at-runtime args-support) ) )
     6(compile -s -O -d2 args.scm -j args)
     7(compile -s args.import.scm)
     8
     9(install-extension
     10 'args
     11 `(,(dynld-name "args") ,(dynld-name "args.import") )
     12 `((version 1.4)
     13   (documentation "args.html")
     14   ))
     15
Note: See TracChangeset for help on using the changeset viewer.