flickr.ss
;; Flickr API.

;; Copyright (c) 2007 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; (at dvanhorn (dot cs brandeis edu))

;; This module implements flickr.* using reflection.

;;    A little food and drink, uh huh,
;;    Nothing too fancy.
;;    Lambda, veal, and some good ol' wine,
;;    This is the life for me.
;;    But don't shit where you eat, my friend.
;;                    --- Ween

(module flickr mzscheme
  (provide (all-defined)
           (all-from "method.ss"))
  
  ;; This module makes compile-time calls to the Flickr reflection API.
  (require-for-syntax "flickr-reflection.ss"  
                      "method.ss"
                      (lib "list.ss")
                      (lib "match.ss"))
  
  ;; Using the reflection API, this expands into bindings for the complete
  ;; Flickr API.
  (define-syntax (bind-flickr stx)
    
    (define all-method-names
      (parameterize ((non-text-tags (list* 'methods (non-text-tags))))
        (match (flickr.reflection.getMethods)
          ((('methods _ ('method _ method-name) ...)) method-name))))
    
    (define (get-method-info method-name)  ;; String -> Method-info
      (parameterize ((non-text-tags (list* 'method 'arguments 'errors (non-text-tags))))
        (match (flickr.reflection.getMethodInfo #:method_name method-name)
          ((('method (('name name) 
                      ('needslogin needs-login) 
                      ('needssigning needs-signing) 
                      ('requiredperms _)) . method-specs)
            ('arguments () . argument-specs)
            ('errors () . error-specs))
           
           (make-method-info 
            name
            (flickr-true? needs-login)
            (flickr-true? needs-signing)
            #f ;; ignored for now.
            #f 
            #f
            #f
            (map (match-lambda
                   (('argument (('name name) (optional opt)) . description)
                    (make-argument-info name (flickr-true? opt) description)))
                 argument-specs))))))
    
    (define (make-method-provide/contract mi)
      (let ((method-name (string->symbol (method-info-name mi))))
        `(provide/contract
          (,method-name (->* () (required-keywords ,@(map (lambda (ai) (string->keyword (argument-info-name)))
                                                          (filter (lambda (x) (not (argument-info-optional? x)))
                                                                  (method-info-arguments mi)))) any)))))
    
    (define (make-method-definition mi)
      (let ((method-name (string->symbol (method-info-name mi))))
        `(begin
           (define ,method-name 
             (lambda/kw (#:key
                         ,@(map 
                            (lambda (ai) (string->symbol (argument-info-name ai)))
                            (method-info-arguments mi))
                         #:all-keys ak)
               (apply ,(if (method-info-needs-signing? mi) 'invoke-method-signed 'invoke-method)
                      #:method ,(method-info-name mi)
                      #:api_key (or api_key (current-api-key))
                      ak))))))
    
    (datum->syntax-object
     stx
     (list* 'begin
            '(require (lib "kw.ss") "method.ss")
            (map make-method-definition (map get-method-info all-method-names)))))
  
  (bind-flickr))