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

[honu] honu forms implemented in racket must call honu->racket on the parsed output. add an example to do ocaml style pattern matching

Browse Source
This commit is contained in:
Jon Rafkind 2012-02-14 10:43:10 -07:00
parent 549a7522e3
commit 782664316d
11 changed files with 144 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -76,6 +76,7 @@
[literal:semicolon %semicolon]
[literal:honu-comma %comma]
[literal:honu-comma %comma]
[literal:honu-$ $]
[literal:honu-<- <-]
[literal:honu-in-lines inLines]
[literal:#%brackets #%brackets]

34
collects/honu/core/private/compile.rkt
View File

@ -1,14 +1,20 @@
#lang racket/base
(require syntax/parse
(for-syntax racket/base "debug.rkt" syntax/parse)
"literals.rkt")
;; to get syntax as a literal
(require (for-template racket/base))
(provide (all-defined-out))
(define (honu->racket forms)
(define-literal-set literals (%racket))
(syntax-parse forms #:literal-sets (literals)
#:literals ([literal-syntax syntax])
[(%racket x) (honu->racket #'x)]
[(literal-syntax form) #'#'form]
[(form ...)
(datum->syntax forms
(map honu->racket (syntax->list #'(form ...)))
@ -26,3 +32,31 @@
(syntax-parse code
[(x:stopper rest ...) (strip-stops #'(rest ...))]
[else code]))
(define-syntax repeat$ (lambda (stx) (raise-syntax-error 'repeat$ "dont use this")))
(define-syntax (unexpand-honu-syntax stx)
(define (remove-repeats input)
(debug "Remove repeats from ~a\n" (syntax->datum input))
(define-literal-set locals (repeat$))
(syntax-parse input #:literal-sets (locals)
[(out ... (repeat$ stuff ...) rest ...)
(debug " Found a repeat\n")
(with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))]
[(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))])
(remove-repeats #'(out* ... stuff ... rest* ...)))]
[(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))])
(datum->syntax input
#'(normal* ...)
input input))]
[x #'x]
[else (raise-syntax-error 'repeats "unhandled case" input)]))
(syntax-case stx ()
[(_ expr)
(begin
(debug "Expand honu syntax at phase ~a\n" (syntax-local-phase-level))
(debug " Is ~a expanded ~a\n" (syntax->datum #'expr) (syntax->datum #'#'expr))
(define removed (remove-repeats #'expr))
(debug "Cleansed ~a\n" (syntax->datum removed))
removed)]))

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

@ -475,7 +475,10 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
;; if parsed is #f then we don't want to expand to anything that will print
;; so use an empty form, begin, `parsed' could be #f becuase there was no expression
;; in the input such as parsing just ";".
(with-syntax ([parsed (if (not parsed) #'(begin) (honu->racket parsed))]
(with-syntax ([parsed (if (not parsed) #'(begin)
parsed
#;
(honu->racket parsed))]
[(unparsed ...) unparsed])
(debug "Final parsed syntax\n~a\n" (pretty-format (syntax->datum #'parsed)))
(if (null? (syntax->datum #'(unparsed ...)))

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

@ -333,7 +333,9 @@
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(var:honu-declaration . rest)
(define result #'(%racket (define-values (var.name ...) var.expression)))
(define result
(with-syntax ([var.expression (honu->racket #'var.expression)])
#'(%racket (define-values (var.name ...) var.expression))))
(values result #'rest #t)])))
(provide (rename-out [honu-with-syntax withSyntax]))

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

@ -31,6 +31,7 @@
honu-for-syntax
honu-for-template
honu-prefix
honu-$
;; FIXME: in-lines should probably not be here
honu-in-lines
%racket)

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

@ -8,6 +8,7 @@
"literals.rkt"
"parse2.rkt"
"debug.rkt"
"compile.rkt"
racket/base)
(for-meta 2 syntax/parse
racket/base
@ -15,6 +16,7 @@
"compile.rkt")
"literals.rkt"
"syntax.rkt"
(for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt")
#;
(for-syntax "honu-typed-scheme.rkt")
syntax/parse)
@ -155,14 +157,29 @@
;; Do any honu-specific expansion here
(define-honu-syntax honu-syntax
(lambda (code context)
(define (compress-dollars stx)
(define-literal-set local-literals (honu-$))
(syntax-parse stx #:literal-sets (local-literals)
[(honu-$ x ... honu-$ rest ...)
(with-syntax ([(rest* ...) (compress-dollars #'(rest ...))])
#'((repeat$ x ...) rest* ...))]
[(x rest ...)
(with-syntax ([x* (compress-dollars #'x)]
[(rest* ...) (compress-dollars #'(rest ...))])
#'(x* rest* ...))]
[x #'x]))
(syntax-parse code #:literal-sets (cruft)
[(_ (#%parens stuff ...) . rest)
(define context (stx-car #'(stuff ...)))
(define compressed (compress-dollars #'(stuff ...)))
(values
(with-syntax ([stuff* (datum->syntax context
(syntax->list #'(stuff ...))
(syntax->list compressed)
context context)])
#'(%racket #'stuff*))
;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
(with-syntax ([(out ...) #'stuff*])
#'(%racket #'(%racket (unexpand-honu-syntax (do-parse-rest-macro out ...))))))
#; #'(%racket-expression (parse-stuff stuff ...))
#'rest
#f)])))
@ -179,17 +196,7 @@
(provide honu-pattern)
(define-honu-syntax honu-pattern
(lambda (code context)
(define (bind-to-results pattern)
(with-syntax ([((pattern-variable.name pattern-variable.result) ...)
(find-pattern-variables pattern)])
(with-syntax ([(each ...)
(for/list ([name (syntax->list #'(pattern-variable.name ...))]
[result (syntax->list #'(pattern-variable.result ...))])
(with-syntax ([name name]
[result result])
#'(#:with result result)))])
#'(each ...))))
(define (generate-pattern name literals original-pattern)
(define (generate-pattern name literals original-pattern maybe-out)
(define variables (find-pattern-variables original-pattern))
(define use (generate-temporaries variables))
(define mapping (make-hash))
@ -206,8 +213,10 @@
[(literal ...) literals]
[(new-pattern ...) (convert-pattern original-pattern mapping)]
[((withs ...) ...) withs]
#;
[((bindings ...) ...) (bind-to-results original-pattern)])
[(result-with ...) (if maybe-out
(with-syntax ([(out ...) maybe-out])
#'(#:with result (syntax out ...)))
#'())])
#'(%racket (begin-for-syntax
(define-literal-set local-literals (literal ...))
(define-splicing-syntax-class name
@ -215,12 +224,15 @@
[local-literals #:at name])
[pattern (~seq new-pattern ...)
withs ... ...
; bindings ... ...
result-with ...
])))))
(syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens literal ...)
(#%braces pattern ...)
(~optional (#%braces out ...))
. rest)
(values (generate-pattern #'name #'(literal ...) #'(pattern ...))
(values (generate-pattern #'name #'(literal ...)
#'(pattern ...)
(attribute out))
#'rest
#f)])))

11
collects/honu/core/private/parse-helper.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/base
(require (for-syntax racket/base
"parse2.rkt"))
(provide (all-defined-out))
(define-syntax (do-parse-rest-macro stx)
(syntax-case stx ()
[(_ stuff ...)
(do-parse-rest #'(stuff ...) #'do-parse-rest-macro)]))

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

@ -154,13 +154,16 @@
(debug 2 "Comma? ~a ~a\n" what is)
is)
(provide do-parse-rest)
(define (do-parse-rest stx parse-more)
(syntax-parse stx
[(_ stuff ...)
[(stuff ...)
(define-values (parsed unparsed)
(parse (strip-stops #'(stuff ...))))
(debug "Parse more: ~a unparsed ~a\n" parsed unparsed)
(define output (if parsed
parsed
#;
(honu->racket parsed)
#'(void)))
(debug "Output ~a\n" output)
@ -169,20 +172,29 @@
[parse-more parse-more])
(if (null? (syntax->datum #'(unparsed-out ...)))
#'output
#'(begin output (parse-more unparsed-out ...))))]))
#'(begin output (parse-more unparsed-out ...))))]
[() #'(begin)]))
(define (do-parse-rest/local stx)
(define name (gensym 'local-parser))
(define local-parser (with-syntax ([name name])
#'(define-syntax (name stx)
(do-parse-rest stx #'name))))
(syntax-case stx ()
[(_ stuff (... ...))
(do-parse-rest #'(stuff (... ...)) #'name)]))))
(with-syntax ([local local-parser]
[parsed (do-parse-rest stx name)])
#'(begin local parsed)))
(with-syntax ([(stx ...) stx]
[name name])
#'(begin local (name stx ...)))))
#|
(provide do-parse-rest-macro)
(define-syntax (do-parse-rest-macro stx)
(with-syntax ([stx stx])
#'(do-parse-rest stx #'do-parse-rest-macro)))
(syntax-case stx ()
[(_ stuff ...)
(do-parse-rest #'(stuff ...) #'do-parse-rest-macro)]))
|#
(provide honu-body)
(define-syntax-class honu-body
@ -259,7 +271,7 @@
precedence left current)
(define re-parse
(with-syntax ([(x ...) #'parsed])
(do-parse-rest/local #'(nothing x ...))))
(do-parse-rest/local #'(x ...))))
(debug "Reparsed ~a\n" (pretty-format (syntax->datum re-parse)))
#;
(define re-parse (let-values ([(re-parse re-unparse)
@ -287,7 +299,8 @@
[pattern x:str]
[pattern x:number])
(debug "parse ~a precedence ~a left ~a current ~a\n" (syntax->datum 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)
#;
@ -299,7 +312,7 @@
(debug "Native racket expression ~a\n" #'racket)
(if current
(values (left current) stream)
(values (left stream) #'()))
(values (left #'racket) #'()))
#;
(if current
(values (left current) stream)
@ -325,7 +338,6 @@
[(honu-macro? #'head)
(debug "Macro ~a\n" #'head)
(do-macro #'head #'(rest ...) precedence left current stream)]
#;
[(parsed-syntax? #'head)
(debug "Parsed syntax ~a\n" #'head)
(do-parse #'(rest ...) precedence left #'head)]

4
collects/honu/core/read.rkt
View File

@ -37,8 +37,8 @@
(:~ #\")))
(define-lex-abbrev string (:: #\" (:* string-character) #\"))
(define-lex-abbrev operator (:or "+=" "-=" "*=" "/="
"+" "!=" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<="
">=" "<-" "<" ">" "!" "::" ":=" "%"))
"+" "!=" "=>" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<="
">=" "<-" "<" ">" "!" "::" ":=" "%" "$"))
(define-lex-abbrev block-comment (:: "/*"
(complement (:: any-string "*/" any-string))
"*/"))

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

@ -5,6 +5,7 @@
(for-syntax syntax/parse
racket/base
honu/core/private/literals
honu/core/private/compile
honu/core/private/parse2))
(provide sqr)
@ -22,8 +23,10 @@
[(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ...
. rest)
(values
#'(%racket (cond
[clause.result body.result]
...))
(with-syntax ([(clause.result ...) (map honu->racket (syntax->list #'(clause.result ...)))]
[(body.result ...) (map honu->racket (syntax->list #'(body.result ...)))])
#'(%racket (cond
[clause.result body.result]
...)))
#'rest
#t)])))

31
collects/tests/honu/match.honu Normal file
View File

@ -0,0 +1,31 @@
#lang honu
var => = 0
pattern match_pattern (){ [element:expression] } { [element] }
pattern match_clause (| =>){ | pattern:match_pattern => out:expression , }
macro mymatch(with){
thing:expression with
clause:match_clause ...
} {
syntax(
cond
$ clause_pattern == thing: clause_out, $ ...
else: -2
/*
if (clause_pattern == thing){
clause_out
} else {
-2
}
*/)
}
mymatch [1] with
| [1] => 5,
| [2] => 6,
// mymatch [1] with | [2] => 5