;;;; Optparser package internals
;; more info: http://fraggod.net/prj/lisp_optparser/
;;
;; Example usage:
;;
;; (with-argv (argz concurrency verbose)
;; 	(*posix-argv* ("c" "concurrency" :value t) ("v" "verbose"))
;; 	(format t
;; 		"Arguments: ~s~%Optional values:~% verbose: ~s~% concurrency: ~s~%"
;; 		argz verbose concurrency))
;;
;; (parse-argv '("enc" "-c" "10" "--logging" "path1" "--timeout=20" "path2")
;; 	'(("v" :value nil :idx 1) ("verbose" :value nil :idx 1)
;; 		("l" :value nil :idx 2) ("logging" :value nil :idx 2) ("log-to" :value t :idx 2)
;; 		("c" :value t :idx :conc) ("concurrency" :value t :idx :conc)
;; 		("timeout" :value 10)))
;; => (values ("enc" "path1" "path2") ((1 . nil) ("timeout" . "20") (:conc . "10") (2 . t)))
;;


(in-package cl-user)
(defpackage optparser
	(:use :cl)
	(:export
		:argv-let
		:argv-bind
		:get-argv
		:getopt
		:parse-argv))
(in-package optparser)


;; Public macros
(defmacro argv-let ((args &rest specz) argv &body body)
	"Bind args and given vars to argz and each
subsequent option specifier, parsed from argv."
	`(argv-bind (,args ,@(mapcar #'car specz)) (,argv ,@(mapcar #'cadr specz)) ,@body))
	;; `(multiple-value-bind (,args ,@(mapcar #'car specz)) (get-argv ,argv ,@(mapcar #'cadr specz)) ,@body))

(defmacro argv-bind ((args &rest vars) (argv &rest specz) &body body)
	"Bind given vars to argz and each
subsequent option specifier, parsed from argv."
	`(multiple-value-bind (,args ,@vars) (get-argv ,argv ,@specz) ,@body))

(defmacro get-argv (argv &rest specz)
	"Yield multiple values for argz and each
subsequent option specifier, parsed from argv."
	`(multiple-value-bind (argz optz)
		(parse-argv ,argv
			',(loop with spec-forms for spec in specz for idx upfrom 0 do
				(loop with val = (when (eql (car (last spec 2)) :value) (car (last spec)))
					for opt in spec while (stringp opt)
					do (push `(,opt :value ,val :idx ,idx) spec-forms))
				finally (return (nreverse spec-forms))))
		(values-list (cons argz
			(loop for idx upto ,(1- (length specz)) collect (cdr (assoc idx optz)))))))

(defmacro getopt (argv &rest specz)
	"Yield argz list and optz alist, indexed by first element in spec,
skipping it as option alias if it's non-string."
	`(parse-argv ,argv
		',(loop with spec-forms for spec in specz do
			(loop
				with val = (when (eql (car (last spec 2)) :value) (car (last spec)))
				and idx = (car spec)
				for opt in spec while (or (stringp opt) (eql opt idx))
				if (stringp opt) do
				(push (list opt :value val :idx idx) spec-forms))
			finally (return (nreverse spec-forms)))))



;; Internal helper  macro
(defmacro aset (alist &rest valspec)
	(let (result)
		(loop while valspec do
			(let
				((var (pop valspec)) (val (pop valspec)))
				(push `(setf ,alist (acons ,var ,val ,alist)) result)))
		`(progn ,@result)))



;; Main worker function
(defun parse-argv (argv spec)
	"Return argz list and optz alist, parsed from argv,
according to alist of a given specz with value and
resulting opt index specification."
	(let (argz optz opt pos val idx)
		;; --- parse available argz/optz
		(loop for arg in argv do
			(if (and (not (eql val t)) (>= (length arg) 2) (eql (char arg 0) #\-))
				;; -- option
				(progn
					(setf opt (string-left-trim "-" arg))
					(if (eql (char arg 1) #\-)
						;; - long option
						(progn
							;; split arg into opt=val
							(if (setf pos (position #\= opt))
								(setf
									val (subseq opt (1+ pos))
									opt (subseq opt 0 pos))
								(setf val nil))
							;; get optspec for opt
							(when (not (setf pos (cdr (assoc opt spec :test #'string=))))
								(error (format nil "Invalid option: ~a" arg)))
							(setf idx (or (getf pos :idx) opt))
							;; push val or set flag to parse it, if necessary
							(if (getf pos :value)
								;; need val
								(if val
									(aset optz idx val)
									(setf val t)) ;; parse next arg as val
								;; true / false switch
								(when
									(or (not val)
										(find val ;; truth valz for --opt=VAL flag forms
											#("true" "enabled" "yes" "ok" "y" "1" "t")
											:test #'string=))
									(aset optz idx t))))
						;; - short option(s)
						(loop for arg across opt do
							(when (eql val t)
								(error (format nil "Option ~a requires an argument" opt)))
							(when (not (setf pos (cdr (assoc arg spec :test #'string=))))
								(error (format nil "Invalid option: ~a" arg)))
							(setf idx (or (getf pos :idx) opt))
							(if (getf pos :value)
								(setf opt arg val t)
								(aset optz idx t)))))
				;; -- arg / val
				(if (eql val t)
					(progn
						(aset optz idx arg)
						(setf val nil))
					(push arg argz)))
			finally (when (eql val t) ;; check that the last arg wasn't val-hungry option
				(error (format nil "Option ~a requires an argument" opt))))
		;; --- set defaults for unavailable optz w/ :value spec
		(dolist (arg spec)
			(setf
				opt (car arg)
				pos (cdr arg)
				idx (or (getf pos :idx) opt)
				val (getf pos :value))
			(when (not (assoc idx optz))
				(aset optz idx val)))
		;; --- return the stuff
		(values (nreverse argz) optz)))