(module  Options
   (export (option-flag o)
	   (option-values o)
	   (option-n-args o)
	   (option-args arg-desc-list)
	   (option-action o)
	   (option-usage o)
	   (option-map f ot)
	   (option-grovel option-table argv-list)
	   ))

(define (unit) unit)

(define (unit? u) (eq? u unit))


(define (fold f i l)
   (let loop ((l l) (v i))
      (if (null? l) v
	  (loop (cdr l) (f (car l) v)))
      ))


(define (vector-map f v)
   (let* ((l (vector-length v))
	  (nv (make-vector l)))
      (let fill ((i 0))
	 (if (< i l)
	     (begin
		(vector-set! nv i (f (vector-ref v i)))
		(fill (+ 1 i)))
	     nv))
      ))

(define (take lis k)
  (let recur ((lis lis) (k k))
    (if (zero? k) '()
	(cons (car lis)
	      (recur (cdr lis) (- k 1))))))



(define (option-flag o) (vector-ref o 0))
(define (option-values o) (vector-ref o 1))
(define (option-n-args o) (vector-ref o 2))
(define (option-action o) (vector-ref o 3))

(define (option-args arg-desc-list)
   (if (null? arg-desc-list) ""
       (apply string-append
	      (cdr
	       (fold (lambda (desc l) (append (list " " desc) l))
		     '()
		     arg-desc-list)))))

(define (option-usage o)
   (let ((flag (option-flag o)))
      (if (unit? flag) ""
	  (string-append flag " " (option-values o)))
      ))

(define (option-map f v) (vector-map f v))

(define null-option-table (vector))

(define (option-grovel option-table argv-list)
   (let* ((n-options (vector-length option-table))
	  (else-option
	   ; this could be made better, probably at the point
	   ; where we assemble the option-table...
	   (let find-else ((index 1))
	      (if (>= index n-options)
		  unit
		  (let ((check (vector-ref option-table index)))
		     (if (unit? (option-flag check))
			 check
			 (find-else (+ 1 index))))
		  ))))
      (let grovel ((option-list argv-list) (unused '()))
	 (if (null? option-list)
             (reverse unused)
	     (let ((maybe-flag (car option-list))
		   (maybe-values (cdr option-list)))
		(let search ((index 0))
		   (if (< index n-options)
		       (let ((option (vector-ref option-table index)))
			  (if (equal? maybe-flag (option-flag option))
			      (let* ((n-args (option-n-args option))
				     (option-values (take maybe-values n-args))
				     (unused-options (list-tail maybe-values n-args)))
				 (apply (option-action option) option-values)
				 (grovel unused-options unused))
			      (search (+ index 1))))
		       (if (unit? else-option)
			   (grovel maybe-values (cons maybe-flag unused))
			   (begin
			      ((option-action else-option) maybe-flag)
			      (grovel maybe-values unused)))
		       )))
	     ))
      ))