(define-library (csc flag)
  (export
    *args*
    bool-flag
    define-bool-flag
    define-flag
    parse-error-flag
    parse-error-msg
    parse-error?
    parse-flags)
  (import (scheme base)
          (only (csc hash-map)
            compare-strings
            key-not-found-error?
            lookup
            make-map)
          (only (csc loop)
            loop)
          (only (csc strings)
            prefix?
            contains?))
  (begin


    (define (bool-flag s)
      (cond
        ((member s '("1" "t" "T" "true" "TRUE" "True"))
          #t)
        ((member s '("0" "f" "F" "false" "FALSE" "False"))
          #f)
        (else (error "Argument could not be parsed as a boolean" s))))


    (define *parsers* (make-map compare-strings))


    (define-syntax define-flag
      (syntax-rules ()
        ((define-flag name flag type default)
          (define name (begin
                         (set! *parsers* (insert *parsers* flag (lambda (x) (set! name (type x)))))
                         default)))))


    (define *args* '())


    (define-record-type <parse-error>
      (make-parse-error msg flag)
      parse-error?
      (msg parse-error-msg)
      (flag parse-error-flag))


    (define (parse-flags)
      (define args (cdr (command-line)))
      ; Is this legal?
      (define (parse-one)
        (match args
          ('() #f)
          ((s . _) when (or (not (has-prefix? s "-"))
                            (string=? "-" s))
            #f)
          ((s . rest) when (string=? "--" s)
            (set! args rest)
            #f)
          ((s . rest)
            (define name (if (has-prefix? s "--")
                           (string-copy s 2)
                           (string-copy s 1)))
            (when (or (string=? "" name)
                      (has-prefix? name "-")
                      (has-prefix? name "="))
              (raise (make-parse-error "bad flag syntax" s)))
            ; It's a flag. Does it have an argument?
            (set! args rest)
            (define value (match (split name "=" 2)
                            ((a b)
                              (set! name a)
                              b)
                            (_ #f)))
            (define parser (guard (e ((key-not-found-error? e)
                                       (raise (make-parse-error "flag provided but not defined" s))))
                             (lookup *parsers* name)))
            (if (eq? parser bool-flag)  ; Special case: doesn't need an arg.
              (if value
                (parser value)
                (parser "true"))
              (begin
                ; It must have a value, which might be the next argument.
                (when (and (not value)
                           (not (null? args)))
                  ; value is the next arg
                  (set! value (car args))
                  (set! args (cdr args)))
                (unless value
                  (raise (make-parse-flag "flag needs an argument" s)))
                (parser value)))
            #t)))
      (loop while (parse-one))
      (set! *args* args))))