(import scheme (chicken base) (chicken string) (chicken file posix)
        (srfi 13) test getopt-long matchable)

(define (symbol-upcase str)
  (string->symbol (string-upcase str)))

(define grammar1
  `((lockfile-dir (required #t)
                  (value #t)
                  (single-char #\k)
		  (value (required DIR)
			 (predicate ,directory?)))

    (verbose (required #f)
             (single-char #\v)
             (value #f))

    (x-includes (single-char #\x)
                (multiple #t)
		(value #t))

    (rnet-server (single-char #\y)
		 (value (required SERVER)
			(predicate ,string?)))

    (help        (single-char #\h))           
    ))
;;;

(define cmdline1 '("-h" "-vk" "/tmp" 
		   "--x-includes=/usr/include"
		   "--x-includes=/usr/local/include"
		   "--rnet-server=lamprod" 
		   "--" "-fred" "foo2" "foo3"
		   ))
  
(define opts (getopt-long cmdline1 grammar1))

(define dispatch (make-option-dispatch opts grammar1))

(test-group "grammar1"

    (test
     `((@ "-fred" "foo2" "foo3") 
       (rnet-server . "lamprod") 
       (x-includes . "/usr/local/include")
       (x-includes . "/usr/include")
       (lockfile-dir . "/tmp") 
       (verbose . #t)
       (help . #t))
     (getopt-long cmdline1 grammar1)
     )
    
    (test
     "lamprod"
     (dispatch 'rnet-server)
     )

    (test
     '("/usr/local/include" "/usr/include" )
     (dispatch 'x-includes)
     )

    )


(define opt-defaults
  `(
    (morphology-file . S)
    (meta-filter     . (("Note" "")))
    (index-fields    . ("Neuron Name" "Note"))
    ))

(define (defopt x)
  (alist-ref x opt-defaults))


(define grammar2
  `(
    (data-dir
     "set download directory (default is a randomly generated name in /tmp)"
     (single-char #\d)
     (value (required DIR)))

    (morphology-file 
      "download morphology files (Original, Standard or None, default is standard)"
      (single-char #\m)
      (value (required "O, S, or N")
	     (default ,(defopt 'morphology-file))
	     (predicate ,(lambda (arg) 
			   (case (symbol-upcase arg)
			     ((O S N ORIGINAL STANDARD)  #t)
			     (else     #f))))
	     (transformer ,symbol-upcase)))

    (meta-filter
     "filter pages based on metadata"
     (single-char #\f)
     (value   (required "NAME1=REGEXP1[,NAME2!=REGEXP2 ...]")    
	      (default ,(defopt 'meta-filter))
	      (transformer ,(lambda (arg)
			      (map 
			       (lambda (x) 
				 (match (string-split x "!=")
					((n v) `(!= . ,(map string-trim-both (list n v))))
					(else
					 (begin
					   (match (string-split x "=")
						  ((n v )  `(= . ,(map string-trim-both (list n v))))
						  ((n)     `(= ,(string-trim-both n) "")))))))
			       (string-split arg ",")))
			   )))

    (print-metadata
     "print metadata"
     (single-char #\p))

    (i 	       "make index file")

    (index-fields
     
     ,(begin
	(string-append "comma-separated list of index fields "
		       "(default is " (string-intersperse (defopt 'index-fields) ", ") ")")
	)

     (value       (required "FIELD1,...")
		  (default  ,(defopt 'index-fields))
		  (transformer 
		   ,(lambda (arg) (map string-trim-both (string-split (or arg "") ","))))))

    (help  "Print help"
	    (single-char #\h))
  
  ))

(define cmdline2 '("--meta-filter=\"Note=,Archive Name=Brown\""
		   "-d" "data" "FormSubmit.html"))
    
(long-option-value-quoting #t)

(test-group "grammar2"

    (test
     `((@ "FormSubmit.html") 
       (data-dir . "data") 
       (meta-filter (= "Note" "") 
		    (!= "Archive Name" "Brown")))
     (getopt-long cmdline2 grammar2)
     )
    
    )

(define cmdline3 '("--meta-filter=Note=,Archive Name=Brown"
		   "-d" "data" "FormSubmit.html"))
    
(long-option-value-quoting #f)

(test-group "grammar2"

    (test
     `((@ "FormSubmit.html") 
       (data-dir . "data") 
       (meta-filter (= "Note" "") 
		    (!= "Archive Name" "Brown")))
     (getopt-long cmdline3 grammar2)
     )
    
    )

(test-group "uknown option"

    (test
     (list "u")
     (let-values (((_ unknown)
		   (getopt-long '("-u") grammar2 unknown-option-handler: (lambda (x) x))))
       unknown))
    
    )


(test-exit)