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

[honu] dont produce an extra void expression in a block. add a for form to iterate over a list. add an example of linq with xml

Browse Source
This commit is contained in:
Jon Rafkind 2011-09-13 12:14:40 -06:00
parent 1650294a83
commit 501efef8a1
9 changed files with 167 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/honu/core/main.rkt
View File

@ -13,6 +13,7 @@
(for-syntax (rename-out [honu-expression expression]))
(rename-out [#%dynamic-honu-module-begin #%module-begin]
[honu-top-interaction #%top-interaction]
[honu-with-input-from-file with_input_from_file]
[honu-class class]
[honu-new new]
[honu-function function]
@ -42,8 +43,10 @@
[honu-not not] [honu-not !]
[honu-structure structure]
[honu-structure struct]
[literal:honu-prefix prefix]
[literal:honu-then then]
[literal:colon :]
[literal:honu-in in]
[literal:semicolon |;|]
[literal:honu-comma |,|]
[literal:#%brackets #%brackets]

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

@ -35,8 +35,8 @@
(define-honu-syntax honu-new
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens arg ...) . rest)
(define new #'(make-object name arg ...))
[(_ name (#%parens arg:honu-expression ...) . rest)
(define new #'(make-object name arg.result ...))
(values
new
#'rest

2
collects/honu/core/private/honu-typed-scheme.rkt
View File

@ -459,7 +459,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
[(_ forms ...)
(define-values (parsed unparsed) (honu-expand #'(forms ...)))
(debug "expanded ~a unexpanded ~a\n"
(syntax->datum parsed)
(if parsed (syntax->datum parsed) parsed)
(syntax->datum unparsed))
(with-syntax ([parsed parsed]
[(unparsed ...) unparsed])

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

@ -5,8 +5,11 @@
"struct.rkt"
"honu-typed-scheme.rkt"
racket/class
racket/require
(only-in "literals.rkt"
honu-then
honu-in
honu-prefix
semicolon)
(for-syntax syntax/parse
"literals.rkt"
@ -50,13 +53,19 @@
(define-honu-syntax honu-for
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-=)
#:literals (honu-= honu-in)
[(_ 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)
#'rest
#t)]
[(_ iterator:id honu-in stuff:honu-expression
honu-do body:honu-expression . rest)
(values #'(for ([iterator stuff.result])
body.result)
#'rest
#t)])))
(provide honu-if)
@ -131,7 +140,7 @@
[(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" 'left)])))))
[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
@ -170,12 +179,41 @@
[(_ rest ...)
#'(#%top-interaction . (honu-unparsed-begin rest ...))]))
(begin-for-syntax
(define-splicing-syntax-class require-form
#:literals (honu-prefix)
#:literal-sets (cruft)
[pattern (~seq honu-prefix prefix module)
#:with result #'(prefix-in prefix module)]
[pattern x:str #:with result #'x]
[pattern x:id #:with result #'x
#:when (not ((literal-set->predicate cruft) #'x))]))
(define-for-syntax (racket-names->honu name)
(regexp-replace* #rx"-" "_"))
(provide honu-require)
(define-honu-syntax honu-require
(lambda (code context)
(syntax-parse code
[(_ module . rest)
[(_ form:require-form ... . rest)
(values
#'(require module)
#'(require (filtered-in (lambda (name)
(regexp-replace* #rx"-"
(regexp-replace* #rx"->" name "_to_")
"_"))
(combine-in form.result ...)))
#'rest
#f)])))
(provide honu-with-input-from-file)
(define-honu-syntax honu-with-input-from-file
(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)))
(values
with
#'rest
#f)])))

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

@ -25,7 +25,9 @@
honu-? honu-: honu-comma honu-. #%braces #%brackets #%parens colon
honu-and
ellipses-comma ellipses-comma* ellipses-repeat
honu-in
honu-for-syntax
honu-for-template)
honu-for-template
honu-prefix)
(define-literal-set cruft (#%parens #%brackets #%braces semicolon colon honu-comma honu-<-))

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

@ -122,7 +122,9 @@
(define parsed-property (gensym 'honu-parsed))
(define (parsed-syntax syntax)
(syntax-property syntax parsed-property #t))
(if syntax
(syntax-property syntax parsed-property #t)
syntax))
(define (parsed-syntax? syntax)
(syntax-property syntax parsed-property))
@ -178,7 +180,7 @@
[pattern x:number])
(debug "parse ~a precedence ~a left ~a current ~a\n" stream precedence left current)
(define final (if current current #'(void)))
(define final (if current current #f))
(syntax-parse stream #:literal-sets (cruft)
[()
(values (left final) #'())]
@ -332,10 +334,12 @@
[code code])
(define-values (parsed unparsed)
(parse (strip-stops code)))
(debug "Parsed ~a unparsed ~a\n" (syntax->datum parsed)
(syntax->datum unparsed))
(debug "Parsed ~a unparsed ~a\n" (if parsed (syntax->datum parsed) parsed)
(if unparsed (syntax->datum unparsed) unparsed))
(if (empty-syntax? unparsed)
(with-syntax ([(use ...) (reverse (cons parsed all))])
(with-syntax ([(use ...) (reverse (if parsed
(cons parsed all)
all))])
#'(begin use ...))
(loop (cons parsed all)
unparsed))))
@ -372,7 +376,7 @@
(debug "honu expression syntax class\n")
(define-values (parsed unparsed)
(parse stx))
(debug "parsed ~a\n" parsed)
(debug "parsed ~a\n" (if parsed (syntax->datum parsed) parsed))
(list (parsed-things stx unparsed) parsed)))
(provide identifier-comma-list)

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

@ -24,6 +24,7 @@
(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)]

48
collects/tests/honu/linq.honu Normal file
View File

@ -0,0 +1,48 @@
#lang honu
require prefix xml_ xml;
require "linq.rkt";
class Xml(data){
Descendants(name){
[new Xml(element): element <- find_descendants(data, name)]
}
Element(name){
new Xml(get_element(data, name));
}
Value(){
get_text(data);
}
getData(){ data }
};
read_xml(){
xml_permissive_xexprs(true);
xml_xml_to_xexpr(xml_document_element(xml_read_xml()));
}
loadXml(file){
with_input_from_file(file){
new Xml(read_xml());
}
}
var xml = loadXml("test.xml");
printf("xml ~a\n", xml);
printf("data: ~a\n", xml.getData());
printf("table1: ~a\n", xml.Descendants("Table1"));
struct test{name, address};
var addresses = linq from add in xml.Descendants("Table1")
select test(add.Element("familyName").Value(),
add.Element("address").Value());
printf("addresses ~a\n", addresses);
for add in addresses do {
printf("name ~a address ~a\n", add.name, add.address);
}

56
collects/tests/honu/linq.rkt Normal file
View File

@ -0,0 +1,56 @@
#lang racket/base
(require honu/core/private/macro2
honu/core/private/honu-typed-scheme
honu/core/private/literals
racket/list
racket/match
(for-syntax racket/base
honu/core/private/literals
honu/core/private/parse2
syntax/parse))
(define-literal linq-from linq-select)
(provide linq (rename-out [linq-from from]
[linq-select select]))
(define-honu-syntax linq
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-in)
[(_ linq-from name:id honu-in
(~var store honu-expression)
linq-select what:honu-expression . rest)
(define out
#'(for/list ([name store.result])
what.result))
(values out #'rest #f)])))
#|
var addresses = linq from add in xml.Descendants("Table1")
select new {
Name = add.Element("familyName").Value,
Address = add.Element("address").Value
};
|#
(provide find-descendants)
(define (find-descendants xexpr name)
(match xexpr
[(list root root-attributes elements ...)
(filter (lambda (element)
(match element
[(list (? (lambda (x) (string=? name (symbol->string x)))) stuff ...) #t]
[else #f]))
elements)]))
(provide get-element)
(define (get-element xexpr name)
(first (find-descendants xexpr name)))
(provide get-text)
(define (get-text xexpr)
(match xexpr
[(list name attributes text)
text]))