From 769dfb9e34b33e0243a0abe717affaec167d7582 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 10 Aug 2018 17:15:01 +0200 Subject: [PATCH] syntax/parse: add hpat:single; {single,head}-pattern types disjoint --- racket/collects/syntax/parse/private/opt.rkt | 5 +++++ .../collects/syntax/parse/private/parse.rkt | 19 +++++++++-------- .../syntax/parse/private/rep-patterns.rkt | 16 ++++++++++++-- racket/collects/syntax/parse/private/rep.rkt | 21 +++++++++++-------- 4 files changed, 41 insertions(+), 20 deletions(-) diff --git a/racket/collects/syntax/parse/private/opt.rkt b/racket/collects/syntax/parse/private/opt.rkt index b3b6556819..d8ce3cf019 100644 --- a/racket/collects/syntax/parse/private/opt.rkt +++ b/racket/collects/syntax/parse/private/opt.rkt @@ -223,6 +223,8 @@ [(pat:post pattern) (pattern-factorable? pattern)] ;; ---- + [(hpat:single inner) + (pattern-factorable? inner)] [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _)) commit?] [(hpat:seq inner) @@ -303,6 +305,8 @@ [(and (pat:post? a) (pat:post? b)) (pattern-equal? (pat:post-pattern a) (pat:post-pattern b))] ;; --- + [(and (hpat:single? a) (hpat:single? b)) + (pattern-equal? (hpat:single-pattern a) (hpat:single-pattern b))] [(and (hpat:var/p? a) (hpat:var/p? b)) (and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b)) (bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b)) @@ -460,6 +464,7 @@ [(action:undo stmts) (list '~undo)] [(action:ord ap _ _) (list '~ord (pattern->sexpr ap))] [(action:post ap) (list '~post (pattern->sexpr ap))] + [(hpat:single sp) (pattern->sexpr sp)] [(hpat:var/p name parser _ _ _ _) (cond [(and parser (regexp-match #rx"^parser-(.*)$" (symbol->string (syntax-e parser)))) => (lambda (m) (format-symbol "~a:~a" (or name '_) (cadr m)))] diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index e4437a89b9..013a0d98df 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -748,6 +748,7 @@ Conventions: (syntax-case stx () [(fdh hpat) (syntax-case #'hpat () + [#s(hpat:single sp) #'(first-desc:S sp)] [#s(hpat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) #'(quote desc)] [#s(hpat:seq lp) #'(first-desc:L lp)] [#s(hpat:describe _hp desc _t? _r) @@ -756,7 +757,7 @@ Conventions: [#s(hpat:commit hp) #'(first-desc:H hp)] [#s(hpat:ord hp _ _) #'(first-desc:H hp)] [#s(hpat:post hp) #'(first-desc:H hp)] - [_ #'(first-desc:S hpat)])])) + [_ #'#f])])) (define-syntax (first-desc:L stx) (syntax-case stx () @@ -845,6 +846,11 @@ Conventions: (syntax-case stx () [(parse:H x cx rest-x rest-cx rest-pr head pr es k) (syntax-case #'head () + [#s(hpat:single pattern) + #'(parse:S x cx + ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) + #s(pat:pair pattern #s(internal-rest-pattern)) + pr es (lambda (rest-x rest-cx rest-pr) k))] [#s(hpat:describe pattern description transparent? role) #`(let ([es* (es-add-thing pr description transparent? role es)] [pr* (if 'transparent? pr (ps-add-opaque pr))]) @@ -968,12 +974,7 @@ Conventions: (with ([fail-handler fail-to-succeed] [cut-prompt fail-to-succeed]) ;; to be safe (parse:H x cx rest-x rest-cx rest-pr subpattern pr es - (fh0 undo-stack (failure* pr0 es0)))))] - [_ - #'(parse:S x cx - ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) - #s(pat:pair head #s(internal-rest-pattern)) - pr es (lambda (rest-x rest-cx rest-pr) k))])])) + (fh0 undo-stack (failure* pr0 es0)))))])])) ;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans] ;; In k: attrs(EH-pattern, S-pattern) are bound. @@ -981,14 +982,14 @@ Conventions: (syntax-case stx () ;; == Specialized cases ;; -- (x ... . ()) - [(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar name) #f #f)) + [(parse:dots x cx (#s(ehpat (attr0) #s(hpat:single #s(pat:svar name)) #f #f)) #s(pat:datum ()) pr es k) #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)]) (case status ((ok) (let-attributes ([attr0 result]) k)) (else (fail result))))] ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr - [(parse:dots x cx (#s(ehpat (attr0) #s(pat:integrated _name pred? desc role) #f #f)) + [(parse:dots x cx (#s(ehpat (attr0) #s(hpat:single #s(pat:integrated _name pred? desc role)) #f #f)) #s(pat:datum ()) pr es k) #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)]) (case status diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index 28254b8075..3774bb0e9c 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -99,6 +99,7 @@ A SideClause is just an ActionPattern #| A HeadPattern is one of + (hpat:single SinglePattern) (hpat:var/p Id Id Arguments (Listof IAttr) Stx scopts) (hpat:seq ListPattern) (hpat:action ActionPattern HeadPattern) @@ -114,6 +115,7 @@ A HeadPattern is one of (hpat:peek-not HeadPattern) |# +(define-struct hpat:single (pattern) #:prefab) (define-struct hpat:var/p (name parser argu nested-attrs role scopts) #:prefab) (define-struct hpat:seq (inner) #:prefab) (define-struct hpat:action (action inner) #:prefab) @@ -182,7 +184,8 @@ A RepConstraint is one of (action:post? x))) (define (head-pattern? x) - (or (hpat:var/p? x) + (or (hpat:single? x) + (hpat:var/p? x) (hpat:seq? x) (hpat:action? x) (hpat:and? x) @@ -205,6 +208,12 @@ A RepConstraint is one of (or (single-pattern? x) (head-pattern? x))) +(define (coerce-head-pattern p) + (if (head-pattern? p) p (hpat:single p))) + +(define (head-pattern-not-single? hp) + (and (head-pattern? hp) (not (hpat:single? hp)))) + ;; check-pattern : *Pattern -> *Pattern ;; Does attr computation to catch errors, but returns same pattern. (define (check-pattern p) @@ -291,6 +300,8 @@ A RepConstraint is one of (pattern-attrs sp)] ;; -- H patterns + [(hpat:single sp) + (pattern-attrs sp)] [(hpat:var/p name _ _ nested-attrs _ _) (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] [(hpat:reflect _ _ _ name nested-attrs) @@ -367,6 +378,7 @@ A RepConstraint is one of [(action:post sp) (pattern-has-cut? sp)] ;; -- H patterns + [(hpat:single sp) (pattern-has-cut? sp)] [(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))] [(hpat:reflect _ _ _ name nested-attrs) #f] [(hpat:seq lp) (pattern-has-cut? lp)] @@ -570,6 +582,7 @@ A RepConstraint is one of ;; hpat-nullable : HeadPattern -> AbsNullable (define/memo (hpat-nullable hp) (match hp + [(hpat:single sp) 'no] [(hpat:seq lp) (lpat-nullable lp)] [(hpat:action ap hp) (hpat-nullable hp)] [(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))] @@ -579,7 +592,6 @@ A RepConstraint is one of [(hpat:commit hp) (hpat-nullable hp)] [(hpat:ord hp _ _) (hpat-nullable hp)] [(hpat:post hp) (hpat-nullable hp)] - [(? pattern? hp) 'no] [_ 'unknown])) ;; ehpat-nullable : EllipsisHeadPattern -> AbsNullable diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index aa602e16b1..b483b51af0 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -416,7 +416,7 @@ ;; parse-head-pattern : stx DeclEnv -> HeadPattern (define (parse-head-pattern stx decls) - (parse-*-pattern stx decls #t #f)) + (coerce-head-pattern (parse-*-pattern stx decls #t #f))) ;; parse-action-pattern : Stx DeclEnv -> ActionPattern (define (parse-action-pattern stx decls) @@ -978,7 +978,7 @@ (car patterns)] [else (cond [(ormap head-pattern? patterns) - (create-hpat:or patterns)] + (create-hpat:or (map coerce-head-pattern patterns))] [else (create-pat:or patterns)])])) @@ -1204,25 +1204,25 @@ ;; ============================================================ ;; Fixup pass -(define (fixup-rhs the-rhs allow-head? expected-attrs) +(define (fixup-rhs the-rhs head? expected-attrs) (match the-rhs [(rhs attrs tr? desc vs defs commit? delimit-cut?) - (define vs* (for/list ([v (in-list vs)]) (fixup-variant v allow-head? expected-attrs))) + (define vs* (for/list ([v (in-list vs)]) (fixup-variant v head? expected-attrs))) (rhs attrs tr? desc vs* defs commit? delimit-cut?)])) -(define (fixup-variant v allow-head? expected-attrs) +(define (fixup-variant v head? expected-attrs) (match v [(variant stx sattrs p defs) (parameterize ((current-syntax-context stx)) (define p* (parameterize ((stxclass-lookup-config 'yes)) - (fixup-pattern p allow-head?))) + (fixup-pattern p head?))) ;; (eprintf "~v\n===>\n~v\n\n" p p*) ;; Called just for error-reporting (reorder-iattrs expected-attrs (pattern-attrs p*)) (variant stx sattrs p* defs))])) -(define (fixup-pattern p0 allow-head?) +(define (fixup-pattern p0 head?) (define (S p) (fixup p #f)) (define (S* p) (fixup p #t)) (define (A/S* p) (if (action-pattern? p) (A p) (S* p))) @@ -1304,7 +1304,7 @@ [(pat:and/fixup stx ps) (let ([ps (for/list ([p (in-list ps)]) (cond [(action-pattern? p) (A p)] - [allow-head? (H p)] + [(head-pattern? p) (H p)] [else (I p)]))]) (parse-pat:and/k stx ps))] [(pat:or _ ps _) @@ -1326,6 +1326,9 @@ (define (H p) (match p + [(hpat:single sp) + (let ([sp (fixup sp #t)]) + (if (head-pattern? sp) sp (hpat:single sp)))] ;; [(hpat:var/p name parser argu nested-attrs role scopts) ;; (hpat:var/p name parser argu nested-attrs role scopts)] ;; [(hpat:reflect obj argu attr-decls name nested-attrs) @@ -1360,7 +1363,7 @@ ;; Default: no sub-patterns, just return [p p])) - (if allow-head? (H p0) (S p0))) + (if head? (H p0) (S p0))) ;; ============================================================