suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

almost able to get images parsed. hurrah.

Browse Source
This commit is contained in:
Danny Yoo 2011-08-08 16:43:04 -04:00
parent 18fe652912
commit 604e460a18
2 changed files with 32 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
get-module-bytecode.rkt
View File

@ -2,11 +2,13 @@
(require racket/path (require racket/path
racket/runtime-path racket/runtime-path
syntax/modcode syntax/modcode
racket/contract
"language-namespace.rkt" "language-namespace.rkt"
"logger.rkt" "logger.rkt"
syntax/kerncase syntax/kerncase
(for-template "resource.rkt")) (for-template (planet dyoo/whalesong/lang/kernel)
"resource.rkt")
"resource.rkt")
(provide get-module-bytecode) (provide get-module-bytecode)
@ -74,6 +76,7 @@
[(module id name-id (#%plain-module-begin module-level-form ...)) [(module id name-id (#%plain-module-begin module-level-form ...))
#`(module id name-id (#%plain-module-begin #`(module id name-id (#%plain-module-begin
(require (planet dyoo/whalesong/resource))
#,@(map convert-images-to-resources #,@(map convert-images-to-resources
(syntax->list #'(module-level-form ...)))))])))) (syntax->list #'(module-level-form ...)))))]))))
@ -142,21 +145,21 @@
(set! id #,(on-expr #'subexpr)))] (set! id #,(on-expr #'subexpr)))]
[(quote datum) [(quote datum)
(quasisyntax/loc expr (on-datum #'datum (lambda (v)
(quote #,(on-datum #'datum)))] (quasisyntax/loc expr
(quote #,v))))]
[(quote-syntax datum) [(quote-syntax datum)
(quasisyntax/loc expr (on-datum #'datum (lambda (v)
(quote-syntax #,(on-datum #'datum)))] (quasisyntax/loc expr
(quote-syntax #,v))))]
[(with-continuation-mark key value body) [(with-continuation-mark key value body)
(quasisyntax/loc expr (quasisyntax/loc expr
(with-continuation-mark #,(on-expr #'key) #,(on-expr #'value) #,(on-expr #'body)))] (with-continuation-mark #,(on-expr #'key) #,(on-expr #'value) #,(on-expr #'body)))]
[(#%plain-app subexpr ...) [(#%plain-app subexpr ...)
expr (quasisyntax/loc expr
#;(displayln expr)
#;(quasisyntax/loc expr
(#%plain-app #,@(map on-expr (syntax->list #'(subexpr ...)))))] (#%plain-app #,@(map on-expr (syntax->list #'(subexpr ...)))))]
[(#%top . id) [(#%top . id)
@ -167,21 +170,28 @@
[(#%variable-reference id) [(#%variable-reference id)
expr] expr]
[(#%variable-reference) [(#%variable-reference)
expr]
[else
expr])) expr]))
(define (on-datum datum-stx) (define (on-datum datum-stx k)
(printf "looking at datum: ~s\n" datum-stx) (define-values (image? convert) (parameterize ([current-namespace base-namespace])
datum-stx) (values
(dynamic-require '2htdp/image 'image?)
(dynamic-require 'file/convertible 'convert))))
(cond
[(image? (syntax-e datum-stx))
(with-syntax ([image-bytes (convert (syntax-e datum-stx) 'png-bytes)])
(quasisyntax/loc datum-stx
(make-bytes-resource #f #f image-bytes)))]
[else
(k datum-stx)]))
(define (convert-images-to-resources stx) (define (convert-images-to-resources stx)
(kernel-syntax-case (syntax-disarm stx code-insp) #f (kernel-syntax-case (syntax-disarm stx code-insp) #f
[(#%provide raw-provide-spec ...) [(#%provide raw-provide-spec ...)
stx] stx]

5
resource.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang s-exp "lang/kernel.rkt"
(provide (all-defined-out))
(define-struct bytes-resource (name type bytes))