;;  © 2021 Idiomdrottning and Chris Brannon. LGPL

(module define-options

(define-options)

(import
  scheme (chicken base) (chicken module) (chicken string) (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-strip-directory)
 (only (chicken condition) handle-exceptions))

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

(define-for-syntax uq (gensym 'uq))

(define-for-syntax seq?
	(match-lambda*
	 ((a b) (eq? a (strip-syntax b)))
	 ((a) (lambda (b) (eq? a (strip-syntax b))))))

(define-for-syntax (requote valid)
	(if valid
	 (match-lambda*
		(((and all ((? (seq? 'unquote) q) x))) x)
		((x) (list 'quote x)))
	 (lambda (x) (list 'quote x))))

(define-for-syntax (clean valid)
	(match-lambda*
	 (((name (? string? text) . (and more (= (fn (find
																			(fn (and
																					 (pair? x)
																					 (eq? 'default (strip-syntax (car x)))))
																			x)) def))))
		(cons* name (if def (list 'unquote (list 'conc text " [" ((requote valid) (second def)) "]")) text)
					 (remove (fn (eq? 'default (strip-syntax (car x)))) more)))
	 ((head . tail)
		(cons head
		 (remove (fn (and (pair? x) (eq? 'default (strip-syntax (car x))))) tail)))
	 ((x) x)))

(define-ir-syntax*
  ((define-options program-names grammar)
   `(define-options ,program-names ,grammar ()))
  ((define-options program-names grammar test-args)
   `(begin
      (define ,(inject 'help) #f)
      (define opts-grammar
   			,(with (seq? 'quasiquote (car grammar))
							 (list 'quasiquote
										 (map (clean it)
													(if it
															(cadr grammar)
															(quasiwalk (fn (if (seq? 'unquote x) uq x))
																				 (cadr grammar)))))))
      (define (terminate-with-usage exit-code)
   			(with-output-to-port
   					(current-error-port)
   				(lambda ()
   					(print "Usage: " (program-name) " [OPTIONS]")
   					(display (usage opts-grammar))))
   			(exit exit-code))
      (define opts
   			(if ,(if (pair? program-names)
   							 `(member (pathname-strip-directory (program-name))
													',(map (o symbol->string strip-syntax) program-names))
   							 `(string=? (pathname-strip-directory (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 ,(inject (car x))
   					 (alist-ref ',(car x)
   											opts
   											eq?
   											,((requote (seq? 'quasiquote (car grammar)))
													(car
   												 (alist-ref 'default
   																		(filter pair? x)
   																		seq?
   																		'(#f)))))))
   			 (cadr grammar))
      (define ,(inject 'argument-stragglers)
				(alist-ref '@ opts eq? '()))
      (when ,(inject 'help)
   			(terminate-with-usage 0)))))
)