diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index eccffaa7ed..8afce84c5f 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -40,6 +40,7 @@ [honu-match match] [honu-with with] [literal:honu-where where] + [honu-for-syntax for_syntax] [honu-var var] [honu-val val] [honu-for for] diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 7292c83fc4..67796b0d15 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -18,8 +18,10 @@ (for-syntax syntax/parse syntax/parse/experimental/reflect syntax/parse/experimental/splicing + macro-debugger/emit racket/syntax racket/pretty + racket/string "compile.rkt" "util.rkt" "debug.rkt" @@ -235,19 +237,36 @@ ;; possibly handle other types of data [else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)])))))) +(provide honu-for-syntax) +(define-literal honu-for-syntax) (begin-for-syntax (define (fix-module-name name) (format-id name "~a" (regexp-replace* #rx"_" (symbol->string (syntax->datum name)) "-"))) + (define (combine-paths paths name) + (define all (for/list ([path (if paths + (append paths (list name)) + (list name))]) + (cond + [(identifier? path) (symbol->string (syntax->datum path))] + [(string? path) path] + [else (error 'combine-paths "what is ~a" path)]))) + (format-id name (string-join all "/"))) (define-splicing-syntax-class require-form - #:literals (honu-prefix) + #:literals (honu-prefix honu-for-syntax) #:literal-sets (cruft) - [pattern (~seq honu-prefix prefix module) - #:with result (with-syntax ([module (fix-module-name #'module)]) - #'(prefix-in prefix module))] + [pattern (~seq honu-prefix prefix module:require-form) + #:with result #'(prefix-in prefix module.result)] + [pattern (~seq honu-for-syntax ~! (#%parens module:require-form)) + #:with result #'(for-syntax module.result)] [pattern x:str #:with result #'x] - [pattern x:id - #:with result (with-syntax ([name (fix-module-name #'x)]) #'name) + [pattern (~seq (~seq base:id (~literal honu-/)) ... x:id) + #:with result (with-syntax ([name (combine-paths + (syntax->list #'(base ...)) + (fix-module-name #'x))]) + (emit-remark "require-form" #'honu-for-syntax #'x) + (debug "Plain path: ~a ~a\n" #'name (free-identifier=? #'honu-for-syntax #'x)) + #'name) #:when (not ((literal-set->predicate cruft) #'x))])) (define-for-syntax (racket-names->honu name) @@ -257,13 +276,13 @@ (define-honu-syntax honu-require (lambda (code context) (syntax-parse code - [(_ form:require-form ... . rest) + [(_ form1:require-form form:require-form ... . rest) (values (racket-syntax (require (filtered-in (lambda (name) - (regexp-replace* #rx"-" - (regexp-replace* #rx"->" name "_to_") - "_")) - (combine-in form.result ...)))) + (regexp-replace* #rx"-" + (regexp-replace* #rx"->" name "_to_") + "_")) + (combine-in form1.result form.result ...)))) #'rest #f)]))) diff --git a/collects/honu/core/private/literals.rkt b/collects/honu/core/private/literals.rkt index 3d5e6c9599..9119a9a999 100644 --- a/collects/honu/core/private/literals.rkt +++ b/collects/honu/core/private/literals.rkt @@ -28,7 +28,7 @@ ellipses-comma ellipses-comma* ellipses-repeat honu-in honu-where - honu-for-syntax + ;; honu-for-syntax honu-for-template honu-prefix honu-$ diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index c4529b1a4a..246f4a2f39 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -212,6 +212,15 @@ (do-parse-rest #'(stuff ...) #'do-parse-rest-macro)])) |# +(provide parse-local) +(define-syntax-rule (parse-local code ...) + (let () + (define-syntax (parse-more stx) + (syntax-case stx () + [(_ stuff (... ...)) + (do-parse-rest #'(stuff (... ...)) #'parse-more)])) + (parse-more code ...))) + (provide honu-body) (define-syntax-class honu-body #:literal-sets (cruft) diff --git a/collects/syntax/scribblings/parse/patterns.scrbl b/collects/syntax/scribblings/parse/patterns.scrbl index 481a36a888..a1f047dc82 100644 --- a/collects/syntax/scribblings/parse/patterns.scrbl +++ b/collects/syntax/scribblings/parse/patterns.scrbl @@ -398,7 +398,7 @@ See @tech{@EHpatterns} for more information. @specsubform[(H-pattern @#,def-dotsplus . S-pattern)]{ -Like an ellipses (@ellipses) pattern, but requires at one occurrence +Like an ellipses (@ellipses) pattern, but requires at least one occurrence of the head pattern to be present. That is, the following patterns are equivalent: