;;  © 2021 Idiomdrottning and Chris Brannon. LGPL

(module define-options

(define-options)

(import
  scheme (chicken base) (chicken module) (chicken syntax) brev-separate
 (only (chicken process-context) command-line-arguments program-name)
 (only getopt-long usage getopt-long)
 (only (chicken base) alist-ref)
 (only (chicken port) with-output-to-port)
 (only (chicken pathname) pathname-file)
 (only (chicken condition) handle-exceptions))

(import-for-syntax scheme (chicken base) (chicken syntax) brev-separate tree (chicken process-context) srfi-1 matchable)

(define-ir-syntax*
  ((define-options program-names grammar)
   `(define-options ,program-names ,grammar ()))
  ((define-options program-names grammar test-args)
   `(begin
      (define help #f)
      (define opts-grammar
   	,(tree-remove
   	  (fn (and (pair? x) (eq? 'default (strip-syntax (car x)))))
   	  grammar))
      (define (terminate-with-usage exit-code)
   	(with-output-to-port
   	    (current-error-port)
   	  (lambda ()
   	    (print ,(string-append "Usage: " (program-name) " [OPTIONS]"))
   	    (display (usage opts-grammar))))
   	(exit exit-code))
      (define opts
   	(if ,(if (pair? program-names)
   		 `(member (pathname-file (program-name)) ',(map (o symbol->string strip-syntax) program-names))
   		 `(string=? (pathname-file (program-name)) ,(symbol->string (strip-syntax program-names))))
   	    (handle-exceptions exn
   	      (terminate-with-usage 1)
   	      (getopt-long (cons (program-name)
   				 (command-line-arguments))
   			   opts-grammar))
   	    (getopt-long (cons (program-name)
   			       ',test-args)
   			 opts-grammar)))
      ,@((over
   	  `(define ,(car x)
   	     (alist-ref ',(car x)
   			opts
   			eq?
   			,(car
   			  (alist-ref  'default
   				      (filter pair? x)
   				      (lambda (a b) (eq? a (strip-syntax b)))
   				      '(#f))))))
   	 (cadr grammar))
      (when help
   	(terminate-with-usage 0)))))
)