
;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public Licence version 3,
;; see file doc/LGPL-3.

;; Command-line argument parsing


(library (th-scheme-utilities parse-command-line)


  (export <argument-descriptor>
	  is-argument-descriptor?
	  parse-command-line)


  (import (guile)
	  (rnrs exceptions)
	  (srfi srfi-1)
	  (th-scheme-utilities stdutils)
	  (th-scheme-utilities hrecord))


  (define-hrecord-type <argument-descriptor> ()
    arg-name takes-argument? proc-to-launch)


  (define is-argument-descriptor?
    (get-hrecord-type-predicate <argument-descriptor>))


  (define (handle-long-argument arg-descs str)
    (assert (string? str))
    (let* ((option-str (string-drop str 2))
	   (ich (string-index option-str #\=))
	   (actual-option
	    (if (eqv? ich #f)
		option-str
		(string-take option-str ich)))
	   (option-arg
	    (if (not (eqv? ich #f))
		(string-drop option-str (+ ich 1))
		""))
	   (argdesc (find (lambda (argdesc)
			    (let ((arg-name (hfield-ref argdesc 'arg-name)))
			      (and (string? arg-name)					    
				   (string=? actual-option arg-name))))
			  arg-descs)))
      (if (eqv? argdesc #f)
	  (raise 'unknown-command-line-argument)
	  (let ((takes-argument? (hfield-ref argdesc 'takes-argument?))
		(argument-present? (not (eqv? ich #f))))
	    (cond
	     ((and takes-argument? argument-present?)
	      (let ((proc (hfield-ref argdesc 'proc-to-launch)))
		(proc option-arg)))
	     ((and (not takes-argument?) (not argument-present?))
	      (let ((proc (hfield-ref argdesc 'proc-to-launch)))
		(proc)))
	     ((and takes-argument? (not argument-present?))
	      (display "Missing argument for option ")
	      (display (hfield-ref argdesc 'arg-name))
	      (display ".")
	      (newline)
	      (raise 'required-argument-missing))
	     ((and (not takes-argument?) argument-present?)
	      (display "Unwanted argument for option ")
	      (display (hfield-ref argdesc 'arg-name))
	      (display ".")
	      (newline)
	      (raise 'unwanted-argument))
	     (else 
	      ;; We should never enter here.
	      (raise 'internal-error)))))))


  (define (handle-short-argument arg-descs str index command-line)
    (assert (string? str))
    (if (<= (string-length str) 1)
	(raise 'command-line-syntax-error)
	(let* ((option-char (string-ref str 1))
	       (arg (find (lambda (argdesc)
			    (eqv? (hfield-ref argdesc 'arg-name)
				  option-char))
			  arg-descs))
	       (cmd-len (length command-line)))
	  (if (eqv? arg #f)
	      (raise 'unknown-command-line-argument)
	      (if (hfield-ref arg 'takes-argument?)
		  (begin
		    (if (< (+ index 1) cmd-len)
			(begin
			  (let ((option-arg (list-ref command-line (+ index 1)))
				(proc (hfield-ref arg 'proc-to-launch)))
			    (proc option-arg)))
			(raise 'missing-option-argument))
		    (+ index 2))
		  (let ((proc (hfield-ref arg 'proc-to-launch)))
		    (proc)
		    (+ index 1)))))))


  ;; The program name has to be omitted from command-line.
  (define (parse-command-line command-line arg-descs handle-proper-args)
    (assert (and (list? command-line)
		 (and-map? string? command-line)))
    (assert (and (list? arg-descs)
		 (and-map? is-argument-descriptor? arg-descs)))
    (assert (procedure? handle-proper-args))
    (let ((cmd-len (length command-line))
	  (all-options-handled? #f)
	  (index 0))
      (do () ((or (>= index cmd-len) all-options-handled?))
	(let ((cur-item (list-ref command-line index)))
	  (cond
	   ((string=? cur-item "--")
	    (set! all-options-handled? #t)
	    (set! index (+ index 1)))
	   ((and (> (string-length cur-item) 2)
		 (string=? (string-take cur-item 2) "--"))
	    (handle-long-argument arg-descs cur-item)
	    (set! index (+ index 1)))
	   ((eqv? (string-ref cur-item 0) #\-)
	    (set! index
		  (handle-short-argument arg-descs cur-item index command-line)))
	   (else
	    (set! all-options-handled? #t)))))
      (let ((proper-args
	     (if all-options-handled?
		 (list-tail command-line index)
		 '())))
	(handle-proper-args proper-args)))))
