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

[honu] re-attach the output of macros to the input stream. wrap racket expressions so they dont get reparsed

Browse Source
This commit is contained in:
Jon Rafkind 2011-11-01 18:14:05 -06:00
parent 3379fb8df6
commit b25406db4c
7 changed files with 92 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/honu/core/private/class.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "macro2.rkt"
"literals.rkt"
(for-syntax racket/base
"literals.rkt"
"parse2.rkt"
@ -22,21 +23,18 @@
(syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens constructor-argument ...) (#%braces method:honu-class-method ...) . rest)
(define class
#'(define name (class* object% ()
(super-new)
(init-field constructor-argument ...)
method.result ...)))
(values
class
#'rest
#t)])))
#'(%racket (define name (class* object% ()
(super-new)
(init-field constructor-argument ...)
method.result ...))))
(values class #'rest #t)])))
(provide honu-new)
(define-honu-syntax honu-new
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens arg:honu-expression ...) . rest)
(define new #'(make-object name arg.result ...))
(define new #'(%racket (make-object name arg.result ...)))
(values
new
#'rest

64
collects/honu/core/private/honu2.rkt
View File

@ -10,7 +10,9 @@
honu-then
honu-in
honu-prefix
semicolon)
semicolon
%racket
%racket-expression)
(for-syntax syntax/parse
"literals.rkt"
"parse2.rkt"
@ -26,10 +28,10 @@
(#%braces code ...)
. rest)
(values
#'(lambda (arg ...)
(let-syntax ([do-parse (lambda (stx)
(parse-all #'(code ...)))])
(do-parse)))
#'(%racket-expression (lambda (arg ...)
(let-syntax ([do-parse (lambda (stx)
(parse-all #'(code ...)))])
(do-parse))))
#'rest
#f)])))
@ -39,20 +41,9 @@
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-=)
[(_ name:id honu-= one:honu-expression . rest)
(values #'(define name one.result)
(values #'(%racket (define name one.result))
#'rest
#t)
;; parse one expression
#;
(define-values (parsed unparsed)
(parse #'rest))
#;
(values
(with-syntax ([parsed parsed])
#'(define name parsed))
(with-syntax ([unparsed unparsed])
#'unparsed)
#t)])))
#t)])))
(provide honu-for)
(define-honu-syntax honu-for
@ -62,14 +53,14 @@
[(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression
honu-do body:honu-expression . rest)
(values
#'(for ([iterator (in-range start.result end.result)])
body.result)
#'(%racket (for ([iterator (in-range start.result end.result)])
body.result))
#'rest
#t)]
[(_ iterator:id honu-in stuff:honu-expression
honu-do body:honu-expression . rest)
(values #'(for ([iterator stuff.result])
body.result)
(values #'(%racket (for ([iterator stuff.result])
body.result))
#'rest
#t)])))
@ -80,7 +71,7 @@
#:literals (else honu-then)
[(_ condition:honu-expression honu-then true:honu-expression else false:honu-expression . rest)
(values
#'(if condition.result true.result false.result)
#'(%racket-expression (if condition.result true.result false.result))
#'rest
#f)])))
@ -98,14 +89,14 @@
(lambda (code context)
(syntax-parse code
[(_ expression rest ...)
(values #'(quote expression) #'(rest ...) #f)])))
(values #'(%racket-expression (quote expression)) #'(rest ...) #f)])))
(provide honu-quasiquote)
(define-honu-syntax honu-quasiquote
(lambda (code context)
(syntax-parse code
[(_ expression rest ...)
(values #'(quasiquote expression)
(values #'(%racket-expression (quasiquote expression))
#'(rest ...)
#f)])))
@ -138,14 +129,15 @@
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(let ([left* left])
(cond
[(honu-struct? left*) (let ([use (honu-struct-get left*)])
(use left* 'right))]
[(object? left*) (lambda args
(send/apply left* right args))]
;; possibly handle other types of data
[else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)])))))
#'(%racket-expression
(let ([left* left])
(cond
[(honu-struct? left*) (let ([use (honu-struct-get left*)])
(use left* 'right))]
[(object? left*) (lambda args
(send/apply left* right args))]
;; possibly handle other types of data
[else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))))))
(provide honu-flow)
(define-honu-operator/syntax honu-flow 0.001 'left
@ -204,11 +196,11 @@
(syntax-parse code
[(_ form:require-form ... . rest)
(values
#'(require (filtered-in (lambda (name)
#'(%racket (require (filtered-in (lambda (name)
(regexp-replace* #rx"-"
(regexp-replace* #rx"->" name "_to_")
"_"))
(combine-in form.result ...)))
(combine-in form.result ...))))
#'rest
#f)])))
@ -218,7 +210,7 @@
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ (#%parens name:id) something:honu-expression . rest)
(define with #'(with-input-from-file name (lambda () something.result)))
(define with #'(%racket-expression (with-input-from-file name (lambda () something.result))))
(values
with
#'rest

8
collects/honu/core/private/literals.rkt
View File

@ -29,7 +29,9 @@
honu-in
honu-for-syntax
honu-for-template
honu-prefix)
honu-prefix
%racket
%racket-expression)
(define-syntax-rule (define-literal+set set literal ...)
(begin
@ -37,4 +39,6 @@
(begin-for-syntax
(define-literal-set set (literal ...)))))
(define-literal-set cruft (#%parens #%brackets #%braces semicolon colon honu-comma honu-<-))
(define-literal-set cruft (#%parens #%brackets #%braces
%racket %racket-expression
semicolon colon honu-comma honu-<-))

50
collects/honu/core/private/parse2.rkt
View File

@ -174,33 +174,55 @@
;; parse one form
;; return the parsed stuff and the unparsed stuff
(define (parse input)
(define (do-macro head rest precedence left current stream)
(if current
(values (left current) stream)
(begin
(debug "Honu macro ~a\n" head)
(let-values ([(parsed unparsed terminate?)
((syntax-local-value head)
(with-syntax ([head head]
[(rest ...) rest])
#'(head rest ...))
#f)])
(with-syntax ([(parsed ...) parsed]
[(rest ...) unparsed])
(debug "Output from macro ~a\n" #'(parsed ...))
(do-parse #'(parsed ... rest ...)
precedence left current)
#;
(if terminate?
(values (left #'parsed)
#'rest)
(do-parse #'rest precedence
left #'parsed)))))))
(define (do-parse stream precedence left current)
(define-syntax-class atom
[pattern x:identifier]
[pattern x:str]
[pattern x:number])
(debug "parse ~a precedence ~a left ~a current ~a\n" stream precedence left current)
(debug "parse ~a precedence ~a left ~a current ~a\n" (syntax->datum stream) precedence left current)
(define final (if current current #f))
(syntax-parse stream #:literal-sets (cruft)
[()
(values (left final) #'())]
;; dont reparse pure racket code
[(%racket racket rest ...)
(if current
(values (left current) stream)
(values (left #'racket) #'(rest ...)))]
;; for expressions that can keep parsing
[(%racket-expression racket rest ...)
(if current
(values (left current) stream)
(do-parse #'(rest ...)
precedence left
#'racket))]
[(head rest ...)
(cond
[(honu-macro? #'head)
(if current
(values (left current) stream)
(begin
(debug "Honu macro ~a\n" #'head)
(let-values ([(parsed unparsed terminate?)
((syntax-local-value #'head) #'(head rest ...) #f)])
(with-syntax ([parsed parsed]
[rest unparsed])
(if terminate?
(values (left #'parsed)
#'rest)
(do-parse #'rest precedence
left #'parsed))))))]
(do-macro #'head #'(rest ...) precedence left current stream)]
[(parsed-syntax? #'head)
(do-parse #'(rest ...) precedence left #'head)]
[(honu-operator? #'head)

15
collects/honu/core/private/struct.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "macro2.rkt"
"literals.rkt"
(for-syntax racket/base
"parse2.rkt"
"literals.rkt"
@ -23,12 +24,12 @@
(define out
(with-syntax ([(fields.name/accessor ...)
(make-accessors #'name (syntax->list #'(fields.name ...)))])
#'(struct name (fields.name ...)
#:transparent
#:property honu-struct (lambda (instance name)
(case name
[(fields.name) (fields.name/accessor instance)]
...
[else (error 'dot "no such field name ~a" name)])))))
#'(%racket (struct name (fields.name ...)
#:transparent
#:property honu-struct (lambda (instance name)
(case name
[(fields.name) (fields.name/accessor instance)]
...
[else (error 'dot "no such field name ~a" name)]))))))
(values out #'rest #t)])))

6
collects/honu/private/common.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require honu/core/private/macro2
honu/core/private/literals
(for-syntax syntax/parse
racket/base
honu/core/private/literals
@ -16,7 +17,8 @@
[(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ...
. rest)
(values
#'(cond
[clause.result body.result] ...)
#'(%racket-expression (cond
[clause.result body.result]
...))
#'rest
#t)])))

6
collects/tests/honu/linq.rkt
View File

@ -36,9 +36,9 @@
#'(sort store.result string<?
#:key (lambda (name) order-by.result))
#'store.result)])
#'(for/list ([name order]
guard ...)
select.result)))
#'(%racket (for/list ([name order]
guard ...)
select.result))))
(values out #'rest #f)])))
#|