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

syntax/parse: parse side clauses directly as action patterns

Browse Source 
Eliminates the clause:* structures.
This commit is contained in:
Ryan Culpepper 2016-05-14 16:40:36 -04:00
parent f327a44080
commit 669460da34
4 changed files with 39 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
racket/collects/syntax/parse/private/parse.rkt
View File

@ -712,8 +712,8 @@ Conventions:
#`(parse:A x cx #,action pr es #,k))]
[#s(action:cut)
#'(with ([fail-handler cut-prompt]) k)]
[#s(action:bind (side ...))
#'(bind/sides (side ...) k)]
[#s(action:bind a expr)
#'(let-attributes ([a (wrap-user-code expr)]) k)]
[#s(action:fail condition message)
#`(let ([c (wrap-user-code condition)])
(if c
@ -735,17 +735,6 @@ Conventions:
#'(let ([pr* (ps-add-post pr)])
(parse:A x cx pattern pr* es k))])]))
;; (bind/sides clauses k) : expr[Ans]
;; In k: attrs(clauses) are bound.
(define-syntax (bind/sides stx)
(syntax-case stx ()
[(_ (side ...) k)
(for/fold ([k #'k]) ([side (in-list (reverse (syntax->list #'(side ...))))])
(syntax-case side ()
[#s(clause:attr a expr)
#`(let-attributes ([a (wrap-user-code expr)])
#,k)]))]))
(begin-for-syntax
;; convert-list-pattern : ListPattern id -> SinglePattern
;; Converts '() datum pattern at end of list to bind (cons stx index)
@ -1017,7 +1006,7 @@ Conventions:
(syntax-case stx ()
[(_ a #s(rep:optional _ _ defaults) v)
(with-syntax ([#s(attr name _ _) #'a]
[(#s(clause:attr da de) ...) #'defaults])
[(#s(action:bind da de) ...) #'defaults])
(let ([default
(for/or ([da (in-list (syntax->list #'(da ...)))]
[de (in-list (syntax->list #'(de ...)))])

14
racket/collects/syntax/parse/private/rep-data.rkt
View File

@ -24,11 +24,7 @@
stxclass-commit?
stxclass-delimit-cut?
(struct-out rhs)
(struct-out variant)
(struct-out clause:fail)
(struct-out clause:with)
(struct-out clause:attr)
(struct-out clause:do))
(struct-out variant))
(define (stxclass/s? x)
(and (stxclass? x) (not (stxclass-splicing? x))))
@ -54,10 +50,6 @@ A Variant is
|#
(define-struct variant (ostx attrs pattern definitions) #:prefab)
#|
SideClause is defined in rep-patterns
|#
;; make-dummy-stxclass : identifier -> SC
;; Dummy stxclass for calculating attributes of recursive stxclasses.
(define (make-dummy-stxclass name)
@ -200,9 +192,6 @@ expressions are duplicated, and may be evaluated in different scopes.
(define DeclEntry/c
(or/c den:lit? den:datum-lit? den:class? den:magic-class? den:parser? den:delayed?))
(define SideClause/c
(or/c clause:fail? clause:with? clause:attr? clause:do?))
;; ct-phase = syntax, expr that computes absolute phase
;; usually = #'(syntax-local-phase-level)
(define ct-phase/c syntax?)
@ -218,7 +207,6 @@ expressions are duplicated, and may be evaluated in different scopes.
(provide/contract
[DeclEnv/c contract?]
[DeclEntry/c contract?]
[SideClause/c contract?]
[ct-phase/c contract?]
[make-dummy-stxclass (-> identifier? stxclass?)]

34
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -72,17 +72,20 @@ A ListPattern is a subtype of SinglePattern; one of
A ActionPattern is one of
(action:cut)
(action:fail stx stx)
(action:bind (listof clause:attr))
(action:bind IAttr Stx)
(action:and (listof ActionPattern))
(action:parse SinglePattern stx)
(action:do (listof stx))
(action:ord ActionPattern UninternedSymbol Nat)
(action:post ActionPattern)
A BindAction is (action:bind IAttr Stx)
A SideClause is just an ActionPattern
|#
(define-struct action:cut () #:prefab)
(define-struct action:fail (when message) #:prefab)
(define-struct action:bind (clauses) #:prefab)
(define-struct action:bind (attr expr) #:prefab)
(define-struct action:and (patterns) #:prefab)
(define-struct action:parse (pattern expr) #:prefab)
(define-struct action:do (stmts) #:prefab)
@ -122,11 +125,11 @@ A HeadPattern is one of
#|
An EllipsisHeadPattern is
(ehpat Base HeadPattern RepConstraint)
(ehpat (Listof IAttr) HeadPattern RepConstraint)
A RepConstraint is one of
(rep:once stx stx stx)
(rep:optional stx stx (listof clause:attr))
(rep:optional stx stx (listof BindAction))
(rep:bounds nat/#f nat/#f stx stx stx)
#f
|#
@ -136,19 +139,6 @@ A RepConstraint is one of
(define-struct rep:optional (name over-message defaults) #:prefab)
(define-struct rep:bounds (min max name under-message over-message) #:prefab)
#|
A SideClause is one of
(clause:fail stx stx)
(clause:with pattern stx (listof stx))
(clause:attr IAttr stx)
(clause:do (listof stx))
|#
(define-struct clause:fail (condition message) #:prefab)
(define-struct clause:with (pattern expr definitions) #:prefab)
(define-struct clause:attr (attr expr) #:prefab)
(define-struct clause:do (stmts) #:prefab)
(define (pattern? x)
(or (pat:any? x)
(pat:svar? x)
@ -273,8 +263,8 @@ A SideClause is one of
null]
[(action:fail _ _)
null]
[(action:bind clauses)
(map clause:attr-attr clauses)]
[(action:bind attr expr)
(list attr)]
[(action:and ps)
(append-iattrs (map pattern-attrs ps))]
[(action:parse sp _)
@ -485,3 +475,9 @@ A SideClause is one of
[else
(for/list ([p (in-list patterns)] [index (in-naturals)])
(create-ord-pattern p group index))]))
;; create-action:and : (Listof ActionPattern) -> ActionPattern
(define (create-action:and actions)
(match actions
[(list action) action]
[_ (action:and actions)]))

64
racket/collects/syntax/parse/private/rep.rkt
View File

@ -372,13 +372,6 @@
[pattern (combine-pattern+sides pattern0 sides splicing?)])
(values rest pattern defs))))
(define (side-clauses-attrss clauses)
(for/list ([c (in-list clauses)]
#:when (or (clause:with? c) (clause:attr? c)))
(if (clause:with? c)
(pattern-attrs (clause:with-pattern c))
(list (clause:attr-attr c)))))
;; parse-whole-pattern : stx DeclEnv boolean -> Pattern
;; kind is either 'main or 'with, indicates what kind of pattern declare affects
(define (parse-whole-pattern stx decls [splicing? #f]
@ -404,12 +397,9 @@
(define (combine-pattern+sides pattern sides splicing?)
(check-pattern
(cond [(pair? sides)
(define group (gensym*))
(define actions-pattern
(create-post-pattern
(action:and
(for/list ([side (in-list sides)] [index (in-naturals)])
(create-ord-pattern (side-clause->pattern side) group index)))))
(create-action:and (ord-and-patterns sides (gensym*)))))
(define and-patterns
(ord-and-patterns (list pattern (pat:action actions-pattern (pat:any)))
(gensym*)))
@ -417,19 +407,6 @@
[else (pat:and and-patterns)])]
[else pattern])))
;; side-clause->pattern : SideClause -> ActionPattern
(define (side-clause->pattern side)
(match side
[(clause:fail condition message)
(action:fail condition message)]
[(clause:with wpat expr defs)
(let ([ap (action:parse wpat expr)])
(if (pair? defs) (action:and (list (action:do defs) ap)) ap))]
[(clause:attr attr expr)
(action:bind (list side))]
[(clause:do stmts)
(action:do stmts)]))
;; gensym* : -> UninternedSymbol
;; Like gensym, but with deterministic name from compilation-local counter.
(define gensym*-counter 0)
@ -1022,7 +999,7 @@
(syntax-case stx ()
[(_ clause ...)
(let ([clauses (check-bind-clause-list #'(clause ...) stx)])
(action:bind clauses))]))
(create-action:and clauses))]))
(define (parse-pat:fail stx decls)
(syntax-case stx ()
@ -1097,11 +1074,11 @@
(parse*-optional-pattern stx decls h-optional-directive-table))
(create-hpat:or
(list head
(hpat:action (action:bind defaults)
(hpat:action (create-action:and defaults)
(hpat:seq (pat:datum '()))))))
;; parse*-optional-pattern : stx DeclEnv table
;; -> (values Syntax HeadPattern IAttrs Stx Stx Defaults)
;; -> (values Syntax HeadPattern IAttrs Stx Stx (Listof BindClause))
(define (parse*-optional-pattern stx decls optional-directive-table)
(syntax-case stx ()
[(_ p . options)
@ -1118,7 +1095,7 @@
(options-select-value chunks '#:defaults #:default '())]
[pattern-iattrs (pattern-attrs head)]
[defaults-iattrs
(append-iattrs (side-clauses-attrss defaults))]
(append-iattrs (map pattern-attrs defaults))]
[all-iattrs
(union-iattrs (list pattern-iattrs defaults-iattrs))])
(when (eq? (stxclass-lookup-config) 'yes)
@ -1212,10 +1189,9 @@
(parse-pattern-sides chunks2 decls))
(define-values (decls3 defs)
(decls-create-defs decls2))
(values rest decls3 defs (parse-pattern-sides chunks2 decls))))
(values rest decls3 defs sides)))
;; parse-pattern-sides : (listof chunk) DeclEnv
;; -> (listof SideClause/c)
;; parse-pattern-sides : (listof chunk) DeclEnv -> (listof SideClause)
;; Invariant: decls contains only literals bindings
(define (parse-pattern-sides chunks decls)
(match chunks
@ -1223,28 +1199,28 @@
(wrong-syntax declare-stx
"#:declare can only appear immediately after pattern or #:with clause")]
[(cons (list '#:role role-stx _) rest)
(wrong-syntax role-stx
"#:role can only appear immediately after #:declare clause")]
[(cons (list '#:fail-when fw-stx when-condition expr) rest)
(cons (make clause:fail when-condition expr)
(wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")]
[(cons (list '#:fail-when fw-stx when-expr msg-expr) rest)
(cons (action:fail when-expr msg-expr)
(parse-pattern-sides rest decls))]
[(cons (list '#:fail-unless fu-stx unless-condition expr) rest)
(cons (make clause:fail #`(not #,unless-condition) expr)
[(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest)
(cons (action:fail #`(not #,unless-expr) msg-expr)
(parse-pattern-sides rest decls))]
[(cons (list '#:when w-stx unless-condition) rest)
;; Bleh: when is basically fail-unless without the msg argument
(cons (make clause:fail #`(not #,unless-condition) #'#f)
[(cons (list '#:when w-stx unless-expr) rest)
(cons (action:fail #`(not #,unless-expr) #'#f)
(parse-pattern-sides rest decls))]
[(cons (list '#:with with-stx pattern expr) rest)
(let-values ([(decls2 rest) (grab-decls rest decls)])
(let-values ([(decls2a defs) (decls-create-defs decls2)])
(cons (make clause:with (parse-whole-pattern pattern decls2a #:kind 'with) expr defs)
(cons (create-action:and
(list (action:do defs)
(action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr)))
(parse-pattern-sides rest decls))))]
[(cons (list '#:attr attr-stx a expr) rest)
(cons (make clause:attr a expr)
(cons (action:bind a expr)
(parse-pattern-sides rest decls))]
[(cons (list '#:do do-stx stmts) rest)
(cons (make clause:do stmts)
(cons (action:do stmts)
(parse-pattern-sides rest decls))]
['()
'()]))
@ -1470,7 +1446,7 @@
(define (check-bind-clause clause ctx)
(syntax-case clause ()
[(attr-decl expr)
(make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)]
(action:bind (check-attr-arity #'attr-decl ctx) #'expr)]
[_ (raise-syntax-error #f "expected bind clause" ctx clause)]))
(define (check-stmt-list stx ctx)