Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

212 lines (168 sloc) 7.268 kb
#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 #f
[(#%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)
(kernel-syntax-case (syntax-disarm expr code-insp) #f
[(#%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 #'(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) #f
[(#%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)
#'(void)
;(quasisyntax/loc stx
; (define-syntaxes ids #,(on-expr #'expr)))
]
[(define-values-for-syntax ids expr)
#'(void)
;(quasisyntax/loc stx
; (define-values-for-syntax ids #,(on-expr #'expr)))
]
[else
(on-expr stx)]))
Jump to Line
Something went wrong with that request. Please try again.