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

syntax/parse: started support for backtracking into syntax classes

Browse Source 
incomplete, need to separate descriptions from failure handlers

svn: r18013
This commit is contained in:
Ryan Culpepper 2010-02-08 09:47:52 +00:00
parent 9791384b79
commit 0f08499e54
9 changed files with 170 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/syntax/keyword.ss
View File

@ -58,4 +58,5 @@
[check-expression checker]
[check-identifier checker]
[check-stx-string checker]
[check-stx-boolean checker]
[check-stx-listof (-> checker checker)])

1
collects/syntax/parse/experimental.ss
View File

@ -37,6 +37,7 @@
'(#s(attr a.name a.depth #f) ...)
(quote-syntax parser)
(quote-syntax get-description)
#t
#t)))]))

1
collects/syntax/private/keyword.ss
View File

@ -12,6 +12,7 @@
check-expression
check-identifier
check-stx-boolean
check-stx-string
check-stx-listof)

152
collects/syntax/private/stxparse/parse.ss
View File

@ -44,56 +44,88 @@
[(fail x #:expect p #:fce fce)
#'(enclosing-fail (make-failure x fce p))]))
;; ----
#|
syntax-class protocol
---------------------
for syntax-class SC with args (P ...)
if commit? = #t
parser : Stx P ... -> (U list expectation)
if commit? = #f
parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer
|#
;; (parse:rhs RHS (SAttr ...) (id ...) id boolean)
;; : expr[(values ParseFunction DescriptionFunction)]
;; Takes a list of the relevant attrs; order is significant!
;; Returns either fail or a list having length same as 'relsattrs'
(define-syntax (parse:rhs stx)
(syntax-case stx ()
[(parse:rhs #s(rhs _ _ transparent? _ variants (def ...))
[(parse:rhs #s(rhs _ _ transparent? _ variants (def ...) commit?)
relsattrs (arg ...) get-description splicing?)
#`(with-error-collector
(make-parser
(lambda (x arg ...)
(define (fail-rhs failure)
(with-syntax ([(k-param ...)
(if (syntax-e #'commit?)
#'()
#'(return))]
[k-ref/fail
(if (syntax-e #'commit?)
#'values
#'return)]
[k-ref/ok
(if (syntax-e #'commit?)
#'values
#'(lambda (result) (return (cons enclosing-fail result))))])
#| #`(with-error-collector
(make-parser
(lambda ___)
(collect-error)))
|#
#'(lambda (x k-param ... arg ...)
(define (fail-rhs failure)
(k-ref/fail
(expectation-of-thing (get-description arg ...)
transparent?
(if transparent? failure #f)))
def ...
(syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
(with-enclosing-fail* fail-rhs
(parse:variants x relsattrs variants splicing?))))
(collect-error)))]))
(if transparent? failure #f))))
def ...
(syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
(with-enclosing-fail* fail-rhs
(parse:variants x relsattrs variants splicing? k-ref/ok)))))]))
;; (parse:variants id (SAttr ...) (Variant ...) boolean)
;; : expr[SyntaxClassResult]
(define-syntax (parse:variants stx)
(syntax-case stx ()
[(parse:variants x relsattrs (variant ...) splicing?)
#'(try (parse:variant x relsattrs variant splicing?) ...)]))
[(parse:variants x relsattrs (variant ...) splicing? k-ref)
#'(try (parse:variant x relsattrs variant splicing? k-ref) ...)]))
(define-syntax (parse:variant stx)
(syntax-case stx ()
[(parse:variant x relsattrs variant #f)
[(parse:variant x relsattrs variant #f k-ref)
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
#`(let ([fc (dfc-empty x)])
def ...
(parse:S x fc pattern (variant-success x relsattrs variant ()))))]
[(parse:variant x relsattrs variant #t)
(parse:S x fc pattern (variant-success x relsattrs variant () k-ref))))]
[(parse:variant x relsattrs variant #t k-ref)
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
#`(let ([fc (dfc-empty x)])
def ...
(parse:H x fc pattern rest index
(variant-success x relsattrs variant (rest index)))))]))
(variant-success x relsattrs variant (rest index) k-ref))))]))
;; (variant-success id (SAttr ...) Variant (expr ...)) : expr[SyntaxClassResult]
(define-syntax (variant-success stx)
(syntax-case stx ()
[(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...))
[(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...) k-ref)
#`(convert-sides x sides
(base-success-expr #,(pattern-attrs (wash #'pattern))
relsattrs
(also ...)))]))
(also ...)
k-ref))]))
;; (convert-sides id (Side ...) (m (IAttr ...) . MArgs)) : expr[X]
;; where (m (IAttr ...) MArgs) : expr[X]
@ -126,12 +158,12 @@
;; (base-success-expr (IAttr ...) (SAttr ...) (expr ...) : expr[SCResult]
(define-syntax (base-success-expr stx)
(syntax-case stx ()
[(base-success-expr iattrs relsattrs (also ...))
[(base-success-expr iattrs relsattrs (also ...) k-ref)
(let ([reliattrs
(reorder-iattrs (wash-sattrs #'relsattrs)
(wash-iattrs #'iattrs))])
(with-syntax ([(#s(attr name _ _) ...) reliattrs])
#'(list also ... (attribute name) ...)))]))
#'(k-ref (list also ... (attribute name) ...))))]))
;; ----
@ -209,18 +241,34 @@
(parse:S x fc pattern k))]
[#s(pat:any attrs)
#'k]
[#s(pat:var _attrs name #f () ())
[#s(pat:var _attrs name #f () () _)
#'(let-attributes ([#s(attr name 0 #t) x])
k)]
[#s(pat:var _attrs name parser (arg ...) (nested-a ...))
#`(let ([result (parser x arg ...)])
(if (ok? result)
(let-attributes (#,@(if (identifier? #'name)
#'([#s(attr name 0 #t) x])
#'()))
(let/unpack ((nested-a ...) result)
k))
(fail x #:expect result #:fce fc)))]
[#s(pat:var _attrs name parser (arg ...) (nested-a ...) commit?)
(with-syntax* ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t) x])
#'())]
[ok-e
#'(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
k))]
[fail-e
#'(fail x #:expect result #:fce fc)])
(if (syntax-e #'commit?)
#'(let ([result (parser x arg ...)])
(if (ok? result)
ok-e
fail-e))
#'(parser x
(lambda (result)
(if (ok? result)
(let ([fail-k (car result)]
[result (cdr result)])
(with-enclosing-fail fail-k
ok-e))
fail-e))
arg ...)))]
[#s(pat:datum attrs datum)
#`(let ([d (syntax->datum x)])
(if (equal? d (quote datum))
@ -387,19 +435,35 @@
(with-enclosing-cut-fail previous-cut-fail
(with-enclosing-fail previous-fail
k))))))]
[#s(hpat:var _attrs name parser (arg ...) (nested-a ...))
#`(let ([result (parser x arg ...)])
(if (ok? result)
(let* ([rest (car result)]
[local-fc (cadr result)]
[rest-fc (dfc-append fc local-fc)])
(let-attributes (#,@(if (identifier? #'name)
#'([#s(attr name 0 #t)
(stx-list-take x (dfc->index local-fc))])
#'()))
(let/unpack ((nested-a ...) (cddr result))
k)))
(fail x #:expect result #:fce fc)))]
[#s(hpat:var _attrs name parser (arg ...) (nested-a ...) commit?)
(with-syntax* ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t)
(stx-list-take x (dfc->index local-fc))])
#'())]
[ok-e
#'(let* ([rest (car result)]
[local-fc (cadr result)]
[rest-fc (dfc-append fc local-fc)])
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) (cddr result))
k)))]
[fail-e
#'(fail x #:expect result #:fce fc)])
(if (syntax-e #'commit?)
#'(let ([result (parser x arg ...)])
(if (ok? result)
ok-e
fail-e))
#'(parser x
(lambda (result)
(if (ok? result)
(let ([fail-k (car result)]
[result (cdr result)])
(with-enclosing-fail fail-k
ok-e))
fail-e))
arg ...)))]
[#s(hpat:and (a ...) head single)
#`(parse:H x fc head rest rest-fc
(let ([lst (stx-list-take x (dfc-difference fc rest-fc))])

21
collects/syntax/private/stxparse/rep-data.ss
View File

@ -23,9 +23,10 @@
#|
A stxclass is
(make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean)
(make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean boolean)
|#
(define-struct stxclass (name params attrs parser-name description splicing?)
(define-struct stxclass (name params attrs parser-name description
splicing? commit?)
#:prefab)
(define (stxclass/s? x)
@ -38,7 +39,7 @@ An RHS is
(make-rhs stx (listof SAttr) boolean stx/#f (listof Variant) (listof stx))
definitions: auxiliary definitions from #:declare
|#
(define-struct rhs (ostx attrs transparent? description variants definitions)
(define-struct rhs (ostx attrs transparent? description variants definitions commit?)
#:prefab)
#|
@ -73,7 +74,7 @@ A LiteralSet is
;; make-dummy-stxclass : identifier -> SC
;; Dummy stxclass for calculating attributes of recursive stxclasses.
(define (make-dummy-stxclass name)
(make stxclass (syntax-e name) null null #f #f #f))
(make stxclass (syntax-e name) null null #f #f #f #t))
;; Environments
@ -86,13 +87,13 @@ DeclEnv =
DeclEntry =
(make-den:lit id id)
(make-den:class id id (listof syntax) bool)
(make-den:parser id id (listof SAttr) bool)
(make-den:parser id id (listof SAttr) bool bool)
|#
(define-struct declenv (table conventions))
(define-struct den:lit (internal external))
(define-struct den:class (name class args))
(define-struct den:parser (parser description attrs splicing?))
(define-struct den:parser (parser description attrs splicing? commit?))
(define (new-declenv literals #:conventions [conventions null])
(for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)])
@ -119,7 +120,7 @@ DeclEntry =
stxclass-name)
(wrong-syntax (if blame-declare? name id)
"identifier previously declared"))]
[(struct den:parser (_p _d _a _sp))
[(struct den:parser (_p _d _a _sp _c))
(wrong-syntax id "(internal error) late unbound check")]
['#f (void)])))
@ -137,11 +138,11 @@ DeclEntry =
(make den:class id stxclass-name args))
(declenv-conventions env)))
(define (declenv-put-parser env id parser get-description attrs splicing?)
(define (declenv-put-parser env id parser get-description attrs splicing? commit?)
;; no unbound check, since replacing 'stxclass entry
(make-declenv
(bound-id-table-set (declenv-table env) id
(make den:parser parser get-description attrs splicing?))
(make den:parser parser get-description attrs splicing? commit?))
(declenv-conventions env)))
;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
@ -212,7 +213,7 @@ DeclEntry =
(-> DeclEnv/c identifier? identifier?
DeclEnv/c)]
[declenv-put-parser
(-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean?
(-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean? boolean?
DeclEnv/c)]
[declenv-domain-difference
(-> DeclEnv/c (listof identifier?)

16
collects/syntax/private/stxparse/rep-patterns.ss
View File

@ -16,7 +16,7 @@ A Base is (listof IAttr)
#|
A SinglePattern is one of
(make-pat:any Base)
(make-pat:var Base id id (listof stx) (listof IAttr))
(make-pat:var Base id id (listof stx) (listof IAttr) bool)
(make-pat:literal Base identifier)
(make-pat:datum Base datum)
(make-pat:ghost Base GhostPattern SinglePattern)
@ -37,7 +37,7 @@ A ListPattern is a subtype of SinglePattern; one of
|#
(define-struct pat:any (attrs) #:prefab)
(define-struct pat:var (attrs name parser args nested-attrs) #:prefab)
(define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab)
(define-struct pat:literal (attrs id) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:ghost (attrs ghost inner) #:prefab)
@ -68,7 +68,7 @@ ghost:and is desugared below in create-* procedures
#|
A HeadPattern is one of
(make-hpat:var Base id id (listof stx) (listof IAttr))
(make-hpat:var Base id id (listof stx) (listof IAttr) bool)
(make-hpat:seq Base ListPattern)
(make-hpat:ghost Base GhostPattern HeadPattern)
(make-hpat:and Base HeadPattern SinglePattern)
@ -77,7 +77,7 @@ A HeadPattern is one of
(make-hpat:describe Base stx/#f boolean HeadPattern)
|#
(define-struct hpat:var (attrs name parser args nested-attrs) #:prefab)
(define-struct hpat:var (attrs name parser args nested-attrs commit?) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:ghost (attrs ghost inner) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab)
@ -178,10 +178,10 @@ A Kind is one of
(define (create-pat:any)
(make pat:any null))
(define (create-pat:var name parser args nested-attrs)
(define (create-pat:var name parser args nested-attrs commit?)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var attrs name parser args nested-attrs)))
(make pat:var attrs name parser args nested-attrs commit?)))
(define (create-pat:datum datum)
(make pat:datum null datum))
@ -239,10 +239,10 @@ A Kind is one of
;; ----
(define (create-hpat:var name parser args nested-attrs)
(define (create-hpat:var name parser args nested-attrs commit?)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var attrs name parser args nested-attrs)))
(make hpat:var attrs name parser args nested-attrs commit?)))
(define (create-hpat:seq lp)
(make hpat:seq (pattern-attrs lp) lp))

46
collects/syntax/private/stxparse/rep.ss
View File

@ -124,8 +124,9 @@
;; parser requires stxclasses to be bound.
(define (parse-rhs stx expected-attrs splicing? #:context ctx)
(parameterize ((current-syntax-context ctx))
(define-values (rest description transp? attributes auto-nested? decls defs)
(parse-rhs/part1 stx (and expected-attrs #t)))
(define-values (rest description transp? attributes auto-nested?
decls defs commit?)
(parse-rhs/part1 stx splicing? (and expected-attrs #t)))
(define patterns
(parameterize ((stxclass-lookup-config
(cond [expected-attrs 'yes]
@ -137,9 +138,9 @@
(let ([sattrs
(or attributes
(intersect-sattrss (map variant-attrs patterns)))])
(make rhs stx sattrs transp? description patterns defs))))
(make rhs stx sattrs transp? description patterns defs commit?))))
(define (parse-rhs/part1 stx strict?)
(define (parse-rhs/part1 stx splicing? strict?)
(define-values (chunks rest)
(parse-keyword-options stx rhs-directive-table
#:context (current-syntax-context)
@ -149,9 +150,11 @@
(define opaque? (and (assq '#:opaque chunks) #t))
(define transparent? (not opaque?))
(define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t))
(define commit? ;; FIXME: default value should be (not splicing?) once this works
(options-select-value chunks '#:commit? #:default #t))
(define attributes (options-select-value chunks '#:attributes #:default #f))
(define-values (decls defs) (get-decls+defs chunks strict?))
(values rest description transparent? attributes auto-nested? decls defs))
(values rest description transparent? attributes auto-nested? decls defs commit?))
(define (parse-variants rest decls splicing? expected-attrs)
(define (gather-patterns stx)
@ -218,13 +221,15 @@
[description (generate-temporary class)]
[(arg ...) args])
(values (make den:parser #'parser #'description
(stxclass-attrs sc) (stxclass/h? sc))
(stxclass-attrs sc) (stxclass/h? sc)
(stxclass-commit? sc))
(list #'(define (parser x) (sc-parser x arg ...))
#'(define (description) (description arg ...)))))
(values (make den:parser #'sc-parser #'sc-description
(stxclass-attrs sc) (stxclass/h? sc))
(stxclass-attrs sc) (stxclass/h? sc)
(stxclass-commit? sc))
null))))]
[(struct den:parser (_p _d _a _sp))
[(struct den:parser (_p _d _a _sp _c))
(values entry null)]))
(define (append-lits+litsets lits litsets)
@ -444,10 +449,10 @@
(error 'parse-pat:id
"(internal error) decls had leftover stxclass entry: ~s"
entry)]
[(struct den:parser (parser desc attrs splicing?))
[(struct den:parser (parser desc attrs splicing? commit?))
(if splicing?
(parse-pat:id/h id parser null attrs)
(parse-pat:id/s id parser null attrs))]
(parse-pat:id/h id parser null attrs commit?)
(parse-pat:id/s id parser null attrs commit?))]
['#f
(when #t ;; FIXME: right place???
(unless (safe-name? id)
@ -455,7 +460,7 @@
(let-values ([(name sc) (split-id/get-stxclass id decls)])
(if sc
(parse-pat:var* id allow-head? name sc null)
(create-pat:var name #f null null)))]))
(create-pat:var name #f null null #t)))]))
(define (parse-pat:var stx decls allow-head?)
(define name0
@ -486,31 +491,33 @@
(let ([sc (get-stxclass/check-arg-count scname (length args))])
(parse-pat:var* stx allow-head? name0 sc args))]
[else ;; Just proper name
(create-pat:var name0 #f null null)]))
(create-pat:var name0 #f null null #t)]))
(define (parse-pat:var* stx allow-head? name sc args)
(cond [(stxclass/s? sc)
(parse-pat:id/s name
(stxclass-parser-name sc)
args
(stxclass-attrs sc))]
(stxclass-attrs sc)
(stxclass-commit? sc))]
[(stxclass/h? sc)
(unless allow-head?
(wrong-syntax stx "splicing syntax class not allowed here"))
(parse-pat:id/h name
(stxclass-parser-name sc)
args
(stxclass-attrs sc))]))
(stxclass-attrs sc)
(stxclass-commit? sc))]))
(define (parse-pat:id/s name parser args attrs)
(define (parse-pat:id/s name parser args attrs commit?)
(define prefix (name->prefix name))
(define bind (name->bind name))
(create-pat:var bind parser args (id-pattern-attrs attrs prefix)))
(create-pat:var bind parser args (id-pattern-attrs attrs prefix) commit?))
(define (parse-pat:id/h name parser args attrs)
(define (parse-pat:id/h name parser args attrs commit?)
(define prefix (name->prefix name))
(define bind (name->bind name))
(create-hpat:var bind parser args (id-pattern-attrs attrs prefix)))
(create-hpat:var bind parser args (id-pattern-attrs attrs prefix) commit?))
(define (name->prefix id)
(cond [(wildcard? id) #f]
@ -1038,6 +1045,7 @@
(list '#:opaque)
(list '#:attributes check-attr-arity-list)
(list '#:auto-nested-attributes)
(list '#:commit? check-stx-boolean)
common-parse-directive-table))
;; pattern-directive-table

9
collects/syntax/private/stxparse/sc.ss
View File

@ -59,13 +59,15 @@
(parse-rhs #'rhss #f splicing? #:context stx))])
(with-syntax ([parser (generate-temporary
(format-symbol "parse-~a" (syntax-e #'name)))]
[attrs (rhs-attrs the-rhs)])
[attrs (rhs-attrs the-rhs)]
[commit? (rhs-commit? the-rhs)])
#`(begin (define-syntax name
(make stxclass 'name '(arg ...)
'attrs
((syntax-local-certifier) (quote-syntax parser))
((syntax-local-certifier) (quote-syntax description))
'#,splicing?))
'#,splicing?
'commit?))
(define-values (parser description)
(functions/rhs name (arg ...) attrs rhss #,splicing? #,stx))))))))
@ -103,7 +105,8 @@
(quote-syntax #,(den:parser-parser den))
(quote-syntax #,(den:parser-description den))
(quote #,(den:parser-attrs den))
(quote #,(den:parser-splicing? den))))
(quote #,(den:parser-splicing? den))
(quote #,(den:parser-commit? den))))
defs))))])
#'(begin
def ... ...

7
collects/syntax/scribblings/keyword.scrbl
View File

@ -268,3 +268,10 @@ original procedure accepted.
A @techlink{check-procedure} that accepts syntax strings.
}
@defproc[(check-stx-boolean [stx syntax?] [ctx (or/c false/c syntax?)])
syntax?]{
A @techlink{check-procedure} that accepts syntax booleans.
}