whalesong/expand-out-images.rkt

#lang racket/base

(require racket/runtime-path
         syntax/kerncase
         net/base64
         (for-template "lang/kernel.rkt"))



(provide expand-out-images)

;; my-image-url: (parameterof stx)
;;
;; During the dynamic extent of expand-out-images, this will be defined
;; as the unique name for the image-url function in (planet dyoo/whalesong/image).
(define-runtime-path whalesong/image
  "image.rkt")
(define my-image-url (make-parameter #f))


;; expand-out-images: syntax -> syntax
;; Takes programs and rips out their image snips in favor of calls to
;; image-url.
(define (expand-out-images stx)
  (define expanded (expand stx))
  
  ;; We need to translate image snips in the expanded form so we can
  ;; fruitfully use compiler/zo-parse.    
  (define rewritten
    (parameterize
        ([my-image-url (car (generate-temporaries #'(my-image-url)))])
      
      (define disarmed (syntax-disarm expanded code-insp))
      (kernel-syntax-case disarmed #t
        [(#%expression expr)
         (quasisyntax/loc stx
           (#%expression #,(on-expr #'expr)))]
        
        [(module id name-id (#%plain-module-begin module-level-form ...))
         (with-syntax ([image-library-path
                        (path->string whalesong/image)])
           (quasisyntax/loc stx
             (module id name-id (#%plain-module-begin 
                                 ;; Kludge: I'm trying to get at the image-url
                                 ;; function, but in a way that doesn't clash with the
                                 ;; user's existing program.
                                 (require (only-in (file image-library-path)
                                                   [bitmap/url #,(my-image-url)]))
                                 
                                 #,@(map on-toplevel
                                         (syntax->list #'(module-level-form ...)))))))]
        [(begin top-level-form ...)
         (quasisyntax/loc stx
           (begin #,@(map on-toplevel 
                          (syntax->list #'(top-level-form ...)))))]
        [else
         (on-toplevel expanded)])))
  rewritten)




(define code-insp (current-code-inspector))


(define (on-expr expr)
  (define disarmed (syntax-disarm expr code-insp))
  (kernel-syntax-case disarmed #t
    
    [(#%plain-lambda formals subexpr ...)
     (quasisyntax/loc expr
       (#%plain-lambda formals #,@(map on-expr (syntax->list #'(subexpr ...)))))]
    
    [(case-lambda case-lambda-clauses ...)
     (quasisyntax/loc expr
       (case-lambda #,@(map (lambda (a-clause)
                              (syntax-case (syntax-disarm a-clause code-insp) ()
                                [(formals subexpr ...)
                                 (quasisyntax/loc a-clause
                                   (formals #,@(map on-expr
                                                    (syntax->list #'(subexpr ...)))))]))
                            (syntax->list #'(case-lambda-clauses ...)))))]
    
    [(if test true-part false-part)
     (quasisyntax/loc expr
       (if #,(on-expr #'test)
           #,(on-expr #'true-part)
           #,(on-expr #'false-part)))]
    
    [(begin subexpr ...)
     (quasisyntax/loc expr
       (begin #,@(map on-expr (syntax->list #'(subexpr ...)))))]
    
    [(begin0 subexpr ...)
     (quasisyntax/loc expr
       (begin0 #,@(map on-expr (syntax->list #'(subexpr ...)))))]
    
    [(let-values bindingss body ...)
     (quasisyntax/loc expr
       (let-values #,(syntax-case (syntax-disarm #'bindingss code-insp) ()
                       [(binding ...)
                        (quasisyntax/loc #'bindings
                          (#,@(map (lambda (binding) 
                                     (syntax-case (syntax-disarm binding code-insp) ()
                                       [(ids expr)
                                        (quasisyntax/loc binding
                                          (ids #,(on-expr #'expr)))]))
                                   (syntax->list #'(binding ...)))))])
         #,@(map on-expr (syntax->list #'(body ...)))))]
    
    [(letrec-values bindingss body ...)
     (quasisyntax/loc expr
       (letrec-values #,(syntax-case (syntax-disarm #'bindingss code-insp) ()
                          [(binding ...)
                           (quasisyntax/loc #'bindings
                             (#,@(map (lambda (binding) 
                                        (syntax-case (syntax-disarm binding code-insp) ()
                                          [(ids expr)
                                           (quasisyntax/loc binding
                                             (ids #,(on-expr #'expr)))]))
                                      (syntax->list #'(binding ...)))))])
         #,@(map on-expr (syntax->list #'(body ...)))))]
    
    [(set! id subexpr)
     (quasisyntax/loc expr
       (set! id #,(on-expr #'subexpr)))]
    
    [(quote datum)
     (on-datum #'datum (lambda (v)
                         (quasisyntax/loc expr
                           (quote #,v))))]
    
    [(quote-syntax datum)
     (on-datum #'datum (lambda (v)
                         (quasisyntax/loc expr
                           (quote-syntax #,v))))]
    
    [(with-continuation-mark key value body)
     (quasisyntax/loc expr
       (with-continuation-mark #,(on-expr #'key) #,(on-expr #'value) #,(on-expr #'body)))]
    
    [(#%plain-app subexpr ...)
     (quasisyntax/loc expr
       (#%plain-app
        #,@(map on-expr (syntax->list #'(subexpr ...)))))]
    
    [(#%top . id)
     expr]
    
    [(#%variable-reference (#%top . id))
     expr]
    [(#%variable-reference id)
     expr]
    [(#%variable-reference)
     expr]
    [else 
     expr]))


(define (on-datum datum-stx on-regular-datum)
  (define-values (image? convert) 
    (values
     (dynamic-require '2htdp/image 'image?)
     (dynamic-require 'file/convertible 'convert)))
  
  ;; Translates image values to embeddable uris.  See:
  ;; http://en.wikipedia.org/wiki/Data_URI_scheme
  ;; This code is ripped out of the tracer library written by
  ;; Will Zimrin and Jeanette Miranda.
  ;; returns the data-uri encoding of an image.
  (define (image->uri img)
    (define base64-bytes (base64-encode (convert img 'png-bytes)))
    (string-append "data:image/png;charset=utf-8;base64,"
                   (bytes->string/utf-8 base64-bytes)))
  
  (cond
    [(image? (syntax-e datum-stx))
     ;; When we see an image, we replace it with a call to
     ;; our image-url function.
     (with-syntax ([image-uri 
                    (image->uri (syntax-e datum-stx))])
       (quasisyntax/loc datum-stx
         (#,(my-image-url) image-uri)))]
    
    [else
     (on-regular-datum datum-stx)]))



(define (on-toplevel stx)
  (kernel-syntax-case (syntax-disarm stx code-insp) #t
    [(#%provide raw-provide-spec ...)
     stx]
    
    [(#%require raw-require-spec ...)
     stx]
    
    [(define-values ids expr)
     (quasisyntax/loc stx 
       (define-values ids #,(on-expr #'expr)))]
    
    [(define-syntaxes ids expr)
     (quasisyntax/loc stx 
       (define-syntaxes ids #,(on-expr #'expr)))]
    
    [(define-values-for-syntax ids expr)
     (quasisyntax/loc stx 
       (define-values-for-syntax ids #,(on-expr #'expr)))]
    
    [else
     (on-expr stx)]))