(import chicken scheme)
(import-for-syntax chicken srfi-1)
(use data-structures)
(use intarweb uri-common)

(define-syntax define-method
  (ir-macro-transformer
    (lambda (expr inject compare)
      (assert (pair? expr))
      (let* ((proc (car expr))
	     (defn (cdr expr))
	     (_ (assert (list? defn)))
	     (_ (assert (or (= 4 (length defn)) (= 5 (length defn)))))
	     (sig      (first defn))
	     (name     (car sig))
	     (args     (cdr sig))
	     (pred     (lambda (x) (not (eqv? '#!key x))))
	     (params   (drop-while pred args))
	     (params   (if (null? params) params (cdr params)))
	     (uri-args  (take-while pred args))
	     (mutate-args (reverse
			    (fold (lambda (arg args)
				    (if (list? arg)
				      (cons arg args)))
				  '() uri-args)))
	     (uri-args    (reverse
			    (fold (lambda (arg args)
				    (cons
				      (if (list? arg) (first arg) arg)
				      args))
				  '() uri-args)))
	     (proc-args (reverse
			  (fold (lambda (arg args)
				  (cond ((symbol? arg) (cons arg args))
					((string? arg) args)
					(else (abort (conc "Cannot handle " arg)))))
				'() uri-args)))
	     (uri/req  (second defn))
	     (writer   (third defn))
	     (reader   (fourth defn))
	     (header-reader (if (= 5 (length defn)) (fifth defn) #f))
	     (proc-args (if writer
			  `(,@proc-args body)
			  `(,@proc-args)))
	     (proc-args (if (not (null? params))
			  `(,@proc-args #!key ,@params)
			  `(,@proc-args))))
	;(list 'quote
	      `(define ,name
		 (let* ((writer  ,writer)
			,@(if header-reader `((header-reader ,header-reader)) '())
			(uri/req ,uri/req)
			(uri     (cond ((request? uri/req) (request-uri uri/req))
				       ((uri? uri/req) uri/req)
				       (else (uri-reference uri/req))))
			(req     (cond ((request? uri/req) uri/req)
				       (else (make-request method: (if writer 'POST 'GET)))))
			)
		   (lambda ,proc-args
		     (let* (,@(if (null? mutate-args) '() mutate-args)
			    ,@(if (not (null? uri-args))
			      `((uri (update-uri uri path: (append (uri-path uri) (map ->string (list ,@uri-args)))))
				      ;(_ (pp (uri-path uri)))
			       )
			      '())
			   ,@(if (not (null? params))
			       `((uri (update-uri uri query: (append (uri-query uri)
								     (list ,@(map (lambda (param)
										    ``(,',param . ,(if ,param
												     (->string ,param)
												     ,param)))
										  params))))))
				   '())
			   (req (update-request req uri: uri))
			   )


		       (fprintf (current-error-port) "\n\n\nREQUEST\n")
		       (write-request (update-request req port: (current-error-port)))
		       (fprintf (current-error-port) "\n")


		       (receive (reader uri response)
				(call-with-input-request req ,(if writer '(writer body) #f) ,reader)
				,(if header-reader
					'(values (header-reader (response-headers response)) reader (list uri response))
					'(values reader (list uri response))))
				))))
	      ;)
	))))


-----
(pp (define-method (account/info (uri (lambda (arg) (string-append "hello-" path)))) "https://api.dropbox.com/1/account/info" #f read-json))
(define account/info
  (let* ((writer #f)
         (uri/req "https://api.dropbox.com/1/account/info")
         (uri (cond ((request? uri/req) (request-uri uri/req))
                    ((uri? uri/req) uri/req)
                    (else (uri-reference uri/req))))
         (req (cond ((request? uri/req) uri/req)
                    (else (make-request method: (if writer 'POST 'GET))))))
    (lambda (uri)
      (let* ((uri (lambda (arg) (string-append "hello-" path)))
             (uri (update-uri
                    uri
                    path:
                    (append (uri-path uri) (map ->string (list uri)))))
             (req (update-request req uri: uri)))
        (fprintf (current-error-port) "\n\n\nREQUEST\n")
        (write-request (update-request req port: (current-error-port)))
        (fprintf (current-error-port) "\n")
        (receive
          (reader uri response)
          (call-with-input-request req #f read-json)
          (values reader (list uri response)))))))