From 501efef8a1e43cc09a6aaa464e87c2c60aa30dea Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 13 Sep 2011 12:14:40 -0600 Subject: [PATCH] [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 --- collects/honu/core/main.rkt | 3 + collects/honu/core/private/class.rkt | 4 +- .../honu/core/private/honu-typed-scheme.rkt | 2 +- collects/honu/core/private/honu2.rkt | 48 ++++++++++++++-- collects/honu/core/private/literals.rkt | 4 +- collects/honu/core/private/parse2.rkt | 16 ++++-- collects/honu/core/private/struct.rkt | 1 + collects/tests/honu/linq.honu | 48 ++++++++++++++++ collects/tests/honu/linq.rkt | 56 +++++++++++++++++++ 9 files changed, 167 insertions(+), 15 deletions(-) create mode 100644 collects/tests/honu/linq.honu create mode 100644 collects/tests/honu/linq.rkt diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 368aa31098..db6134d2f9 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -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] diff --git a/collects/honu/core/private/class.rkt b/collects/honu/core/private/class.rkt index 979f1c4dd9..be03516a69 100644 --- a/collects/honu/core/private/class.rkt +++ b/collects/honu/core/private/class.rkt @@ -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 diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index 7264034702..72ca2a2abd 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -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]) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index d488720c66..4de4baac2f 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -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,14 +53,20 @@ (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)]))) + #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) (define-honu-syntax 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)]))) diff --git a/collects/honu/core/private/literals.rkt b/collects/honu/core/private/literals.rkt index 811a63a16a..90cfde8124 100644 --- a/collects/honu/core/private/literals.rkt +++ b/collects/honu/core/private/literals.rkt @@ -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-<-)) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 3c0629a3ca..98fe79e107 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -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) diff --git a/collects/honu/core/private/struct.rkt b/collects/honu/core/private/struct.rkt index 46f8acf316..f472d94f24 100644 --- a/collects/honu/core/private/struct.rkt +++ b/collects/honu/core/private/struct.rkt @@ -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)] diff --git a/collects/tests/honu/linq.honu b/collects/tests/honu/linq.honu new file mode 100644 index 0000000000..c669154050 --- /dev/null +++ b/collects/tests/honu/linq.honu @@ -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); +} diff --git a/collects/tests/honu/linq.rkt b/collects/tests/honu/linq.rkt new file mode 100644 index 0000000000..4a4e70eefa --- /dev/null +++ b/collects/tests/honu/linq.rkt @@ -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]))