[honu] add syntactic patterns. parse the output of macros using a local define-syntax (kind of hackish)
This commit is contained in:
Jon Rafkind
parent
1945ff2709
commit
549a7522e3
|
|
@ -30,6 +30,7 @@
|
|||
[honu-new new]
|
||||
[honu-while while]
|
||||
[honu-macro macro]
|
||||
[honu-pattern pattern]
|
||||
[racket:read-line readLine]
|
||||
[honu-with-input-from-file withInputFromFile]
|
||||
[define-make-honu-operator operator]
|
||||
|
|
@ -87,6 +88,7 @@
|
|||
this
|
||||
#%top
|
||||
#%datum
|
||||
(... ...)
|
||||
))))
|
||||
|
||||
(require "private/honu-typed-scheme.rkt")
|
||||
|
|
|
|||
|
|
@ -6,9 +6,12 @@
|
|||
(provide debug)
|
||||
|
||||
(define-for-syntax (filename path)
|
||||
(define-values (base name dir?)
|
||||
(split-path (build-path path)))
|
||||
name)
|
||||
(if path
|
||||
(let ()
|
||||
(define-values (base name dir?)
|
||||
(split-path (build-path path)))
|
||||
name)
|
||||
"no source"))
|
||||
|
||||
(define (colorize string color)
|
||||
(define colors (hash 'none "0"
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require (for-syntax "transformer.rkt"
|
||||
syntax/parse
|
||||
syntax/stx
|
||||
racket/set
|
||||
racket/syntax
|
||||
"literals.rkt"
|
||||
"parse2.rkt"
|
||||
|
|
@ -18,24 +19,81 @@
|
|||
(for-syntax "honu-typed-scheme.rkt")
|
||||
syntax/parse)
|
||||
|
||||
(define-for-syntax (convert-pattern original-pattern)
|
||||
(define-for-syntax (convert-pattern original-pattern new-names)
|
||||
(define-splicing-syntax-class pattern-type
|
||||
#:literal-sets (cruft)
|
||||
[pattern (~seq name colon class)
|
||||
#:with (result ...) #'((~var name class #:attr-name-separator "_"))]
|
||||
#:with (result ...)
|
||||
(with-syntax ([new-name (hash-ref new-names (syntax-e #'name))])
|
||||
#'((~var new-name class #:attr-name-separator "_")))]
|
||||
[pattern (x:pattern-type ...) #:with (result ...) #'((x.result ... ...))]
|
||||
[pattern x #:with (result ...) #'(x)])
|
||||
(syntax-parse original-pattern
|
||||
[(thing:pattern-type ...)
|
||||
#'(thing.result ... ...)]))
|
||||
|
||||
;; reverse the syntax so that ellipses appear in front of the s-expr
|
||||
;; then search for ellipses nodes and s-exprs of the form class:id %colon name:id
|
||||
;; the output should match the ellipses depth, so for example
|
||||
;; ... foo %colon bar
|
||||
;; output would be
|
||||
;; ((bar ...) (foo_result ...)
|
||||
#;
|
||||
(define-for-syntax (find-pattern-variables original-pattern)
|
||||
(define (reverse-syntax input)
|
||||
(syntax-parse input
|
||||
[(x ...) (datum->syntax #'(x ...)
|
||||
(reverse (for/list ([x (syntax->list #'(x ...))])
|
||||
(reverse-syntax x)))
|
||||
#'(x ...) #'(x ...))]
|
||||
[x #'x]))
|
||||
(define (merge set1 set2)
|
||||
(debug "Merge ~a with ~a\n" set1 set2)
|
||||
(set-union set1 set2))
|
||||
(define (wrap-ellipses stuff)
|
||||
(for/set ([name+result stuff])
|
||||
(syntax-case name+result ()
|
||||
[(name result)
|
||||
#'((name (... ...))
|
||||
(result (... ...)))])))
|
||||
(define (find the-pattern)
|
||||
(debug "Find in ~a\n" (syntax->datum the-pattern))
|
||||
(define-splicing-syntax-class maybe
|
||||
#:literal-sets (cruft)
|
||||
#:literals ([ellipses ...])
|
||||
[pattern (~seq class:id colon name:id)
|
||||
#:attr result
|
||||
(with-syntax ([name.result (format-id #'name "~a_result" #'name)])
|
||||
(set #'(name name.result)))]
|
||||
[pattern (~seq ellipses thing:maybe rest ...)
|
||||
#:attr result
|
||||
(merge (wrap-ellipses (attribute thing.result))
|
||||
(find #'(rest ...)))]
|
||||
[pattern (x:maybe ...) #:attr result (apply set-union (attribute x.result))]
|
||||
[pattern x #:attr result (set)])
|
||||
(syntax-parse the-pattern
|
||||
#:literals ([ellipses ...])
|
||||
[(ellipses thing:maybe rest ...)
|
||||
(debug "Ellipses case\n")
|
||||
(merge (wrap-ellipses (attribute thing.result))
|
||||
(find #'(rest ...)))]
|
||||
[(thing:maybe rest ...)
|
||||
(debug "Normal list case ~a\n" (attribute thing.result))
|
||||
(merge (attribute thing.result) (find #'(rest ...)))]
|
||||
[thing (set)]))
|
||||
(define variables (find (reverse-syntax original-pattern)))
|
||||
(debug "Found variables ~a\n" variables)
|
||||
(for/list ([x variables]) x))
|
||||
|
||||
(define-for-syntax (find-pattern-variables original-pattern)
|
||||
(define-splicing-syntax-class pattern-type
|
||||
#:literal-sets (cruft)
|
||||
[pattern (~seq name colon class)
|
||||
;; we know the output of syntactic classes will end with _result
|
||||
#:with (result ...) (with-syntax ([name.result (format-id #'name "~a_result" #'name)])
|
||||
#'((name name.result)))]
|
||||
#:with (result ...)
|
||||
;; FIXME: dont need name.result anymore here
|
||||
(with-syntax ([name.result (format-id #'name "~a_result" #'name)])
|
||||
#'(name))]
|
||||
[pattern (x:pattern-type ...) #:with (result ...) #'(x.result ... ...)]
|
||||
[pattern x #:with (result ...) #'()])
|
||||
(syntax-parse original-pattern
|
||||
|
|
@ -57,30 +115,39 @@
|
|||
(debug "Pattern is ~a\n" #'(pattern ...))
|
||||
(debug 2 "Pattern variables ~a\n" (find-pattern-variables #'(pattern ...)))
|
||||
(values
|
||||
(with-syntax ([(syntax-parse-pattern ...)
|
||||
(convert-pattern #'(pattern ...))]
|
||||
[((pattern-variable.name pattern-variable.result) ...)
|
||||
(find-pattern-variables #'(pattern ...))])
|
||||
#'(%racket (define-honu-syntax name
|
||||
(lambda (stx context-name)
|
||||
(define-literal-set local-literals (literal ...))
|
||||
(syntax-parse stx
|
||||
#:literal-sets ([cruft #:at name]
|
||||
[local-literals #:at name])
|
||||
[(_ syntax-parse-pattern ... . more)
|
||||
(values
|
||||
;; if the pattern is x:expression then x_result will
|
||||
;; hold the parsed version of x, so we rebind x to
|
||||
;; x_result so you can use just x in the template
|
||||
;; instead of x_result. x_result is still there, too
|
||||
(with-syntax ([pattern-variable.name #'pattern-variable.result]
|
||||
...)
|
||||
(parse-stuff action ...)
|
||||
#;
|
||||
(let-syntax ([parse-more (lambda (stx)
|
||||
(parse-all #'(action ...)))])
|
||||
(parse-more)))
|
||||
#'more #t)])))))
|
||||
(let ()
|
||||
(define pattern-variables (find-pattern-variables #'(pattern ...)))
|
||||
|
||||
;; only need a 1-to-1 mapping here
|
||||
(define mapping (make-hash))
|
||||
(for ([variable pattern-variables])
|
||||
(debug "Update mapping for ~a\n" (syntax-e variable))
|
||||
(hash-set! mapping (syntax-e variable) variable))
|
||||
(with-syntax ([(syntax-parse-pattern ...)
|
||||
(convert-pattern #'(pattern ...) mapping)]
|
||||
[((pattern-variable.name pattern-variable.result) ...)
|
||||
(for/list ([name pattern-variables])
|
||||
(with-syntax ([name name]
|
||||
[name.result (format-id name "~a_result" name)])
|
||||
#'(name name.result)))])
|
||||
#'(%racket (define-honu-syntax name
|
||||
(lambda (stx context-name)
|
||||
(define-literal-set local-literals (literal ...))
|
||||
(syntax-parse stx
|
||||
#:literal-sets ([cruft #:at name]
|
||||
[local-literals #:at name])
|
||||
[(_ syntax-parse-pattern ... . more)
|
||||
(values
|
||||
;; if the pattern is x:expression then x_result will
|
||||
;; hold the parsed version of x, so we rebind x to
|
||||
;; x_result so you can use just x in the template
|
||||
;; instead of x_result. x_result is still there, too
|
||||
(with-syntax ([pattern-variable.name #'pattern-variable.result]
|
||||
...)
|
||||
(parse-stuff action ...))
|
||||
#'more #t)]
|
||||
[else (raise-syntax-error #f "Could not match macro" stx)]
|
||||
))))))
|
||||
#'rest
|
||||
#t)])))
|
||||
|
||||
|
|
@ -107,3 +174,53 @@
|
|||
(with-syntax ([(syntax1* ...) syntax1]
|
||||
[(syntax2* ...) syntax2])
|
||||
#'(syntax1* ... syntax2* ...)))
|
||||
|
||||
;; creates a new syntax/parse pattern
|
||||
(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 variables (find-pattern-variables original-pattern))
|
||||
(define use (generate-temporaries variables))
|
||||
(define mapping (make-hash))
|
||||
(for ([old variables]
|
||||
[new use])
|
||||
(hash-set! mapping (syntax-e old) new))
|
||||
(define withs
|
||||
(for/list ([old variables]
|
||||
[new use])
|
||||
(with-syntax ([old old]
|
||||
[new.result (format-id new "~a_result" new)])
|
||||
#'(#:with old #'new.result))))
|
||||
(with-syntax ([name name]
|
||||
[(literal ...) literals]
|
||||
[(new-pattern ...) (convert-pattern original-pattern mapping)]
|
||||
[((withs ...) ...) withs]
|
||||
#;
|
||||
[((bindings ...) ...) (bind-to-results original-pattern)])
|
||||
#'(%racket (begin-for-syntax
|
||||
(define-literal-set local-literals (literal ...))
|
||||
(define-splicing-syntax-class name
|
||||
#:literal-sets ([cruft #:at name]
|
||||
[local-literals #:at name])
|
||||
[pattern (~seq new-pattern ...)
|
||||
withs ... ...
|
||||
; bindings ... ...
|
||||
])))))
|
||||
(syntax-parse code #:literal-sets (cruft)
|
||||
[(_ name (#%parens literal ...)
|
||||
(#%braces pattern ...)
|
||||
. rest)
|
||||
(values (generate-pattern #'name #'(literal ...) #'(pattern ...))
|
||||
#'rest
|
||||
#f)])))
|
||||
|
|
|
|||
|
|
@ -154,7 +154,7 @@
|
|||
(debug 2 "Comma? ~a ~a\n" what is)
|
||||
is)
|
||||
|
||||
(define (do-parse stx parse-more)
|
||||
(define (do-parse-rest stx parse-more)
|
||||
(syntax-parse stx
|
||||
[(_ stuff ...)
|
||||
(define-values (parsed unparsed)
|
||||
|
|
@ -171,13 +171,26 @@
|
|||
#'output
|
||||
#'(begin output (parse-more unparsed-out ...))))]))
|
||||
|
||||
(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))))
|
||||
(with-syntax ([local local-parser]
|
||||
[parsed (do-parse-rest stx name)])
|
||||
#'(begin local parsed)))
|
||||
|
||||
(define-syntax (do-parse-rest-macro stx)
|
||||
(with-syntax ([stx stx])
|
||||
#'(do-parse-rest stx #'do-parse-rest-macro)))
|
||||
|
||||
(provide honu-body)
|
||||
(define-syntax-class honu-body
|
||||
#:literal-sets (cruft)
|
||||
[pattern (#%braces code ...)
|
||||
#:with result #'(let ()
|
||||
(define-syntax (parse-more stx)
|
||||
(do-parse stx #'parse-more))
|
||||
(do-parse-rest stx #'parse-more))
|
||||
(parse-more code ...))])
|
||||
|
||||
(provide honu-function)
|
||||
|
|
@ -234,6 +247,7 @@
|
|||
(datum->syntax #'head (syntax->list #'(head rest ...))
|
||||
#'head #'head))
|
||||
#f)])
|
||||
#;
|
||||
(emit-remark parsed)
|
||||
#;
|
||||
(emit-local-step stream parsed #:id #'do-macro)
|
||||
|
|
@ -243,13 +257,25 @@
|
|||
#;
|
||||
(do-parse #'(parsed ... rest ...)
|
||||
precedence left current)
|
||||
(define re-parse
|
||||
(with-syntax ([(x ...) #'parsed])
|
||||
(do-parse-rest/local #'(nothing x ...))))
|
||||
(debug "Reparsed ~a\n" (pretty-format (syntax->datum re-parse)))
|
||||
#;
|
||||
(define re-parse (let-values ([(re-parse re-unparse)
|
||||
(parse #'parsed)])
|
||||
(with-syntax ([(re-parse* ...) re-parse]
|
||||
[(re-unparse* ...) re-unparse])
|
||||
(datum->syntax re-parse
|
||||
(syntax->list #'(re-parse* ... re-unparse* ...))
|
||||
(syntax->list
|
||||
#'(%racket
|
||||
(begin (re-parse* ...)
|
||||
(let ()
|
||||
(define-syntax (parse-more stx)
|
||||
(do-parse-rest stx #'parse-more))
|
||||
(parse-more re-unparse* ...)))))
|
||||
re-parse re-parse))))
|
||||
(debug "Reparsed output ~a\n" (pretty-format (syntax->datum re-parse)))
|
||||
(if terminate?
|
||||
(values (left re-parse)
|
||||
#'rest)
|
||||
|
|
@ -270,6 +296,7 @@
|
|||
(values (left final) #'())]
|
||||
;; dont reparse pure racket code
|
||||
[(%racket racket)
|
||||
(debug "Native racket expression ~a\n" #'racket)
|
||||
(if current
|
||||
(values (left current) stream)
|
||||
(values (left stream) #'()))
|
||||
|
|
@ -293,10 +320,14 @@
|
|||
precedence left
|
||||
#'racket))]
|
||||
[(head rest ...)
|
||||
(debug "Not a special expression..\n")
|
||||
(cond
|
||||
[(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)]
|
||||
[(honu-fixture? #'head)
|
||||
(debug 2 "Fixture ~a\n" #'head)
|
||||
|
|
@ -354,6 +385,7 @@
|
|||
(left final)))]
|
||||
|
||||
[(stopper? #'head)
|
||||
(debug "Parse a stopper ~a\n" #'head)
|
||||
(values (left final)
|
||||
stream)]
|
||||
[else
|
||||
|
|
@ -374,9 +406,12 @@
|
|||
#;
|
||||
[(left:no-left function:honu-function . rest)
|
||||
(values #'function.result #'rest)]
|
||||
[else (syntax-parse #'head
|
||||
[else
|
||||
(debug "Parse a single thing ~a\n" #'head)
|
||||
(syntax-parse #'head
|
||||
#:literal-sets (cruft)
|
||||
[(%racket x)
|
||||
(debug 2 "Native racket expression ~a\n" #'x)
|
||||
(if current
|
||||
(values (left current) stream)
|
||||
(do-parse #'(rest ...) precedence left #'head))]
|
||||
|
|
@ -424,6 +459,7 @@
|
|||
(do-parse #'(rest ...) precedence left #'body.result))]
|
||||
;; expression or function application
|
||||
[(#%parens args ...)
|
||||
(debug "Maybe function call with ~a\n" #'(args ...))
|
||||
(if current
|
||||
;; FIXME: 9000 is an arbitrary precedence level for
|
||||
;; function calls
|
||||
|
|
@ -440,6 +476,7 @@
|
|||
(define call (with-syntax ([current current]
|
||||
[(parsed-args ...)
|
||||
(parse-comma-expression #'(args ...)) ])
|
||||
(debug "Parsed args ~a\n" #'(parsed-args ...))
|
||||
#'(current parsed-args ...)))
|
||||
(do-parse #'(rest ...) precedence left call)))
|
||||
(let ()
|
||||
|
|
|
|||
|
|
@ -17,11 +17,11 @@
|
|||
|
||||
(define-for-syntax (make-accessors name fields)
|
||||
(for/list ([field fields])
|
||||
(format-unique-id name "~a-~a" name field)))
|
||||
(format-unique-id field "~a-~a" name field)))
|
||||
|
||||
(define-for-syntax (make-mutators name fields)
|
||||
(for/list ([field fields])
|
||||
(format-unique-id name "set-~a-~a!" name field)))
|
||||
(format-unique-id field "set-~a-~a!" name field)))
|
||||
|
||||
(provide honu-struct-set!)
|
||||
(define (honu-struct-set! instance name value)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user