flickr-syntax.ss
#lang scheme
;; Flickr API.
(require (planet cce/scheme:7/planet)
         (this-package-in method))

(provide (all-defined-out)
         #;(all-from-out "method.ss"))

;; #:auth-token is either optional or required on all methods.
;; #:api_sig is optional on all methods.

;; if parameter signed? is true, then method call signatures are
;; computed and attached.

(define (needs-auth-token? ais)
  (ormap (λ (ai) (and (string=? (argument-info-name ai) "auth_token")
                      (not (argument-info-optional? ai))))
         ais))

(define (method-lambda-spec ais)
  (apply append
         '(#:api_sig [api_sig #f])
         (if (needs-auth-token? ais)
             '()
             '(#:auth_token [auth_token #f]))
         (map (match-lambda 
                [(struct argument-info (name optional? description))
                 (if (string=? name "api_key")
                     `(#:api_key [api_key (current-api-key)])                             
                     `(,(string->keyword name) 
                       ,(if optional?
                            `[,(string->symbol name) #f]
                            (string->symbol name))))])
              ais)))

(define (method-apply-spec ais)
  (append (if (needs-auth-token? ais)
              '()
              `((,'unquote-splicing (if auth_token
                                        (,'quasiquote ((auth_token . (,'unquote auth_token))))
                                        '()))))
          (map (match-lambda
                 [(struct argument-info
                          ((app string->symbol name) optional? description))
                  (if optional?
                      `(,'unquote-splicing (if ,name
                                               (,'quasiquote ((,name . (,'unquote ,name))))
                                               '()))
                      `(,name . (,'unquote ,name)))])
               ais)))

(define (make-method-definition mi)
  (match mi
    [(struct method-info (name needs-login? needs-signing? required-perms 
                               description response explaination arguments errors))
     `(define (,(string->symbol name) ,@(method-lambda-spec arguments))
        ((if (or (signed?) ,needs-signing?)
             (let ((sec (current-sec-key)))
               (λ (args) (invoke-method/signed sec args)))
             invoke-method)             
         (,'quasiquote
          ((method . ,name)
           ,@(method-apply-spec arguments)))))]))
  
(define (flickr-api-link name)
  `(link ,(format "http://www.flickr.com/services/api/~a.html" name)
         ,name))

(define (method-lambda-doc ais)  
  (apply append
         '((#:api_sig api_sig (or/c #f string?) #f))
         (if (needs-auth-token? ais)
             '()
             '((#:auth_token auth_token (or/c #f string?) #f)))
         (map (match-lambda 
                [(struct argument-info (name optional? description))
                 (if (string=? name "api_key")
                     `((#:api_key api_key string? (current-api-key)))
                     `((,(string->keyword name) 
                       ,@(if optional?
                             `[,(string->symbol name) (or/c #f string?) #f]
                             `[,(string->symbol name) string?]))))])
              ais)))


(define (make-method-documentation mi)
  (match mi
    [(struct method-info (name needs-login? needs-signing? required-perms 
                               description response explaination arguments errors))
     `(defproc (,(string->symbol name) ,@(method-lambda-doc arguments)) xexpr? 
        ,description
        ;,explaination
        (para "Flickr link: " ,(flickr-api-link name))
        )]))