#|-------------------- 1.4.2 |# "./args-examples.scm" 4093
(module main ()

  (import scheme chicken)
  (require-library extras ports data-structures)
  (import (only extras printf))
  (import (only ports with-output-to-port))
  (import (only data-structures alist-ref))
  (use args)

;;; Some handy shortcuts for below
                 
(define opts
  (list (args:make-option (c cookie)    #:none     "give me cookie"
          (print "cookie was tasty"))
        (args:make-option (d)           (optional: "LEVEL")  "debug level [default: 1]")
        (args:make-option (e elephant)  #:required "flatten the argument"
          (print "elephant: arg is " arg))
        (args:make-option (f file)      (required: "NAME") "parse file NAME")
        (args:make-option (v V version) #:none     "Display version"
          (print "args-examples $Revision: 1.16 $")
          (exit))
        (args:make-option (abc)         #:none     "Recite the alphabet")
        (args:make-option (h help)      #:none     "Display this text"
          (usage))))

;; Use args:usage to generate a formatted list of options (from OPTS),
;; suitable for embedding into help text.
(define (usage)
  (with-output-to-port (current-error-port)
    (lambda ()
      (print "Usage: " (car (argv)) " [options...] [files...]")
      (newline)
      (print (args:usage opts))
      (print "Report bugs to zbigniewsz at gmail.")))
  ;(exit 1)
  )

;;; Examples

;;(define args (command-line-arguments))
(define args (list "--cookie" "-d" "b.c" "--abc" "-e" "test" "-e" "hello" "e.c" "f.c"))

;;; Process arguments and collate options and arguments into OPTIONS alist,
;;; and operands (filenames) into OPERANDS.  You can handle options as
;;; they are processed, or afterwards.

(define options)
(define operands)
(set!-values (options operands)
  (args:parse args opts))

(if (assq 'abc options)
    (print "A, B, C, D, E, &c."))
(print (alist-ref 'elephant options))  ;; refers to LAST occurrence of -e on command line
(printf "filenames: ~S\n" operands)

;; Output:
;;  cookie was tasty
;;  elephant: arg is test
;;  elephant: arg is hello
;;  A, B, C, D, E, &c.
;;  hello
;;  filenames: ("b.c" "e.c" "f.c")

;;; This will print help and exit [in other words, call USAGE]

(set!-values (options operands)
  (args:parse (append args '("--help"))
              opts))

#|
Usage: ./args-examples [options...] [files...]

 -c, --cookie             give me cookie
 -d [LEVEL]               debug level [default: 1]
 -e, --elephant=ARG       flatten the argument
 -f, --file=NAME          parse file NAME
 -v, -V, --version        Display version
     --abc                Recite the alphabet
 -h, --help               Display this text

Report bugs to zbigniewsz at gmail.
|#

;; (Note that output from --cookie and -e still gets printed,
;; since they are called in order.)

;;; Displays error and invokes help option (to display usage and exit)
;;; due to unrecognized option --fake-option.  This is the
;;; default behavior.

(receive (options operands)
  (args:parse (cons "--fake-option=true" args)
              opts)
  (printf "options: ~S\n" options)
  (printf "operands: ~S\n" operands))

;;; Advanced usage: 
;;; Print each operand as encountered using operand-proc:
;;; and skip unrecognized options, adding them to the options alist.
;; (If you use args:ignore-unrecognized-options, they will not
;; be added to the options alist.)

(receive (options operands)
  (args:parse (cons "--fake-option=true" args)
              opts
              operand-proc:      (lambda (operand options operands)
                                   (print "operand: " operand)
                                   (values options (cons operand operands)))
              unrecognized-proc: args:accept-unrecognized-options)
  (printf "options: ~S\n" options)
  (printf "operands: ~S\n" operands))

#| Output:
cookie was tasty
operand: b.c
elephant: arg is test
elephant: arg is hello
operand: e.c
operand: f.c
options: ((e . "hello") (elephant . "hello") (e . "test") (elephant . "test") (abc . #f) (d . #f) (c . #f) (cookie . #f) (fake-option . "true"))
operands: ("b.c" "e.c" "f.c")
|#
  
)


#|-------------------- 1.4.2 |# "./args.meta" 270
;;; args.meta -*- Hen -*-

((synopsis
   "Command-line argument handling, on top of SRFI 37")
 (author "Jim Ursetto")
 (needs srfi-37)
 (egg "args.egg")
 (doc-from-wiki)
 (license "BSD")
 (category misc)
 (files "args.setup" "args-examples.scm" "args.scm" "args.meta"))

#|-------------------- 1.4.2 |# "./args.scm" 12304


(module args
	
	(;; Option lists
	 args:parse
	 args:help-options
	 args:ignore-unrecognized-options
	 args:accept-unrecognized-options
	 make-args:option
	 ;; Usage printing
	 args:usage
	 args:width
	 args:separator
	 args:indent

	 args:make-option)

	(import scheme chicken extras)

	(require-extension srfi-1 srfi-13 srfi-37)


;;; macro: (args:make-option (OPTION-NAME ...) ARG-TYPE [BODY])
;; Make an args:option record, suitable for passing to args:parse.
;;
;; OPTION-NAME ... is a sequence of short or long option names.  They must be literal
;; symbols; single-character symbols become short options, and longer symbols become
;; long options.  So (args:make-option (c cookie) <...>) specifies a short option -c
;; and long option --cookie.  Underneath, (c cookie) becomes '(#\c "cookie"), as
;; expected by SRFI 37's OPTION.
;; 
;; ARG-DATA is either a pair (ARG-TYPE ARG-NAME) or a plain keyword ARG-TYPE.
;; ARG-TYPE is a keyword that specifies whether the option takes an argument:
;;    #:required   Argument is required
;;    #:optional   Argument is optional
;;    #:none       Does not take an argument (actually, any other value than
;;                 #:required or #:optional is interpreted as #:none)
;; ARG-NAME, if provided, is a string specifying the name of the argument.
;; This name is used in the help text produced by args:usage.
;;
;; BODY is an optional sequence of statements executed when this option is encountered.
;; Behind the scenes, BODY is wrapped in code which adds the current option and its
;; argument to the final options alist.  So, simply leave BODY blank and options
;; will be collected for you.  BODY is an option-processor as defined in SRFI 37,
;; and has access to the variables OPT (the current #<option>), NAME (the option name)
;; and ARG (argument value or #f).

(define-record args:option option arg-name docstring)

;;; procedure: (args:parse ARGS OPTIONS-LIST [OPTIONALS])
;; [chicken-specific dependencies: FPRINTF; GET-KEYWORD; ARGV]

;; Parse ARGS, a list of command-line arguments given as strings,
;; and return two values: an alist of option names (symbols) and their values,
;; and a list of operands (non-option arguments).

;; Operands are returned in order, but options are returned in reverse order.
;; Duplicate options are retained in the options alist, so this lets ASSQ
;; find the -last- occurrence of any duplicate option on the command line.
;; A (name . value) pair is added for each alias of every option found,
;; so any alias is a valid lookup key.

;; OPTIONS-LIST is a list of accepted options, each created by
;; args:make-option.
;;
;; OPTIONALS is an optional sequence of keywords and values:
;;   #:operand-proc PROCEDURE   -- calls PROCEDURE for each operand
;;                                 with arguments OPERAND OPTIONS OPERANDS;
;;                                 returns next seed (values OPTIONS OPERANDS)
;;   #:unrecognized-proc PROCEDURE -- calls PROCEDURE for each unrecognized option
;;                                    with arguments OPTION NAME ARG OPTIONS OPERANDS
;; The default operand-proc is a no-op, and the default unrecognized-proc
;; issues an error message and calls the help option's processor.
;; See the args-fold documentation for usage information and an explanation
;; of the procedure arguments; OPTIONS and OPERANDS are seed values.

;; Two prefabricated unrecognized-procs are provided:
;;    args:ignore-unrecognized-options
;;    args:accept-unrecognized-options

(define (find-named-option name opts)
  (find (lambda (o)
          (member name (option-names (args:option-option o))))
        opts))

(define (find-help-option opts)
  (any (lambda (n) (find-named-option n opts))
       (args:help-options)))

;;; parameter: args:help-options
;; List of option names (strings or single characters, as in SRFI 37)
;; to be considered 'help' options, in order of preference.  args:parse
;; uses this to select a help option from the option list it is passed.
;; This is currently used only for unrecognized options, for which the
;; help option is automatically invoked.

(define args:help-options
  (make-parameter '("help" #\h #\?)))

(define (args:parse args options-list . optionals)
  (let ((help-option (find-help-option options-list)))
    (receive (options operands)
        (args-fold args
                   (map (lambda (x) (args:option-option x))
                        options-list)
                   (get-keyword #:unrecognized-proc optionals
                                (lambda ()  ; thunk
                                  ;; Default: print unrecognized option and execute help procedure,
                                  ;; if a help option was provided.
                                  (lambda (opt name arg options operands)
                                    (fprintf (current-error-port)
                                             "~A: unrecognized option: ~A\n"
                                             (car (argv)) name)
                                    (if help-option
                                        ((option-processor (args:option-option help-option))
                                         opt name arg options operands)
                                        (exit 1)))))
                   ;; modify the operands list for operands
                   (get-keyword #:operand-proc optionals
                                (lambda () (lambda (operand options operands)
                                        (values options
                                                (cons operand operands)))))
                   '()     ;; seed 1: options alist
                   '())    ;; seed 2: operands list
      (values options (reverse operands)))))

;;; Prefabbed unrecognized option procedures
;; Suitable for use as the #:unrecognized-proc in args:parse.

;; Silently ignore unrecognized options, and omit from the options alist.
(define args:ignore-unrecognized-options
  (lambda (o n x options operands)
    (values options operands)))

;; Silently add unrecognized options to the options alist.
(define args:accept-unrecognized-options
  (lambda (o n x options operands)
    (values (cons (cons (string->symbol (if (char? n) (string n) n))
                        x)
                  options)
            operands)))

;;; Usage handling

;; Change #\c => "-c" and "cookie" to "--cookie".
(define (dashify x)
  (if (char? x)
      (string #\- x)
      (string-append "--" x)))
 
;; O is an args:option
;; Join together option names in O with commas, and append the
;; argument type and name
(define (spaces n)
  (let loop ((ls '()) (n n))
    (if (<= n 0)
        (list->string ls)
        (loop (cons #\space ls)
              (- n 1)))))

(define (commify o)   ;; more at home in Stalin?
  (let ((arg-type (lambda (args:o o-name)
                    (let* ((arg-name (args:option-arg-name args:o))
                           (o (args:option-option args:o)))
                      (cond ((option-required-arg? o)
                             (string-append (if (char? o-name)
                                                " " "=")
                                            arg-name))
                            ((option-optional-arg? o)
                             (string-append (if (char? o-name)
                                                " [" "[=")
                                            arg-name "]"))
                            (else ""))))))

    (let loop ((accum #f)
               (names (option-names (args:option-option o))))
      (if (null? names)
          accum
          (let* ((name (car names))
                 (may-be-arg
                  (if (null? (cdr names))
                      (arg-type o name)
                      "")))
            (loop (string-append (or accum
                                     ;; Must deal with first one specially
                                     (if (string? name)
                                         (spaces (+ 2 (string-length (args:separator))))
                                         ""))
                                 (if accum (args:separator) "")
                                 (dashify name) may-be-arg)
                  (cdr names)))))))

;;; parameter: args:width
;; We don't auto-format the left column (the option keys) based on the length of the longest
;; option, but you can override it manually.
;;
;; Example: (parameterize ((args:width 40)) (args:usage opts))
(define args:width (make-parameter 25))
;;; parameter: args:separator
;; The separator used between options.  Default: ", "
;; Example: (parameterize ((args:separator " ")) (args:usage opts))
(define args:separator (make-parameter ", "))
(define args:indent (make-parameter 1))

;; O is an args:option
(define (usage-line o)
  (let ((option-string (commify o)))
    (string-append (spaces (args:indent))
                   (string-pad-right option-string (args:width))
                   (args:option-docstring o) "\n")))

;;; procedure: (args:usage OPTION-LIST)
;; Generate a formatted list of options from OPTION-LIST,
;; and return a string suitable for embedding into help text.
;; The single string consists of multiple lines, with a newline
;; at the end of each line.  Thus, a typical use would be
;; (print (args:usage opts)).
(define (args:usage opts)
  (apply string-append (map usage-line opts)))


;;; macro: (args:make-option (OPTION-NAME ...) ARG-DATA [BODY])

;; OPTION-NAME ... is a sequence of short or long option names.  They must be literal
;; symbols; single-character symbols become short options, and longer symbols become
;; long options.  So (args:make-option (c cookie) <...>) specifies a short option -c
;; and long option --cookie.  Underneath, (c cookie) becomes '(#\c "cookie"), as
;; expected by SRFI 37's OPTION.
;; 
;; ARG-DATA is either a pair (ARG-TYPE ARG-NAME) or a plain keyword ARG-TYPE.
;; ARG-TYPE is a keyword that specifies whether the option takes an argument:
;;    #:required   Argument is required
;;    #:optional   Argument is optional
;;    #:none       Does not take an argument (actually, any other value than
;;                 #:required or #:optional is interpreted as #:none)
;; ARG-NAME, if provided, is a string specifying the name of the argument.
;; This name is used in the help text produced by args:usage.
;;
;; BODY is an optional sequence of statements executed when this option is encountered.
;; Behind the scenes, BODY is wrapped in code which adds the current option and its
;; argument to the final options alist.  So, simply leave BODY blank and options
;; will be collected for you.  BODY is an option-processor as defined in SRFI 37,
;; and has access to the variables OPT (the current #<option>), NAME (the option name)
;; and ARG (argument value or #f).

(define-syntax args:make-option
  (lambda (x r c)
    (let ((names     (cadr x))
	  (arg-data  (caddr x))
	  (docstring (cadddr x))
	  (body      (cddddr x))
	  (%lambda  (r 'lambda))
	  (%begin   (r 'begin))
	  (%values  (r 'values))
	  (%if      (r 'if))
	  (%and     (r 'and))
	  (%not      (r 'not))
	  (%eq?     (r 'eq?))
	  (%car      (r 'car))
	  (%cons     (r 'cons))
	  (%append   (r 'append))
	  (%map     (r 'map))
	  (argv     (r 'argv))
	  (fprintf  (r 'fprintf))
	  (current-error-port    (r 'current-error-port))
	  (option  (r 'option))
	  (make-args:option  (r 'make-args:option))
	  )

      (let* ((srfi37-names (map (lambda (name)
				  (let ((str (->string name)))
				    (if (= (string-length str) 1)
					(string-ref str 0)
					str)))
				names))
	     (arg-name (if (pair? arg-data) (cadr arg-data) "ARG"))
	     (arg-type (if (pair? arg-data) (car arg-data) arg-data)))

	`(,make-args:option
	  (,option ',srfi37-names
		  ,(eq? arg-type #:required)
		  ,(eq? arg-type #:optional)
		  (,%lambda (opt name arg options operands)
		    (,%if (,%and (,%not arg) (,%eq? ,arg-type #:required))
			(,%begin
			  (,fprintf (,current-error-port)
				   "~A: option ~A requires an argument\n"
				   (,%car (,argv)) name)
			  (,%values options operands))
			(,%begin
			  ,@body
			  (,%values (,%append (,%map (,%lambda (n) (,%cons n arg))
						     ',names)
					      options)
				    operands)))))
	  ;;(values (cons (cons name arg) options) operands)))
	  ,arg-name
	  ,docstring)))))

)

#|-------------------- 1.4.2 |# "./args.setup" 304
;;; -*- Hen -*-

(define (dynld-name fn)		
  (make-pathname #f fn ##sys#load-dynamic-extension))	

(compile -s -O -d2 args.scm -j args)
(compile -s args.import.scm)

(install-extension 
 'args
 `(,(dynld-name "args") ,(dynld-name "args.import") )
 `((version 1.4.2)
   (documentation "args.html")
   ))