
;; 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


(define-module (th-scheme-utilities parse-command-line)
  #:declarative? #t
  #:export (<argument-descriptor>
            is-argument-descriptor?
            parse-command-line))


(import (rnrs exceptions)
        (rnrs base)
        (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))))
