mbutterick
/
brag
1
0
Fork 0
Code Issues 3 Pull Requests 1 Projects Releases Wiki Activity

curly quantifier

Browse Source
pull/6/head
Matthew Butterick 7 years ago
parent 99f97b399c
commit 6909f926b7
5 changed files with 52 additions and 59 deletions
Show Stats Download Patch File Download Diff File

6
brag/codegen/codegen.rkt
Unescape Escape View File

@ -301,7 +301,7 @@
[explicit explicit]) [explicit explicit])
([v (in-list (syntax->list #'(vals ...)))]) ([v (in-list (syntax->list #'(vals ...)))])
(loop v implicit explicit))] (loop v implicit explicit))]
[(repeat min val) [(repeat min max val)
(loop #'val implicit explicit)] (loop #'val implicit explicit)]
[(maybe val) [(maybe val)
(loop #'val implicit explicit)] (loop #'val implicit explicit)]
@ -379,7 +379,7 @@
(for/fold ([acc acc]) (for/fold ([acc acc])
([v (in-list (syntax->list #'(vals ...)))]) ([v (in-list (syntax->list #'(vals ...)))])
(loop v acc))] (loop v acc))]
[(repeat min val) [(repeat min max val)
(loop #'val acc)] (loop #'val acc)]
[(maybe val) [(maybe val)
(loop #'val acc)] (loop #'val acc)]
@ -425,7 +425,7 @@
(define a-child (process-pattern v)) (define a-child (process-pattern v))
(sat:add-child! an-or-node a-child)) (sat:add-child! an-or-node a-child))
an-or-node)] an-or-node)]
[(repeat min val) [(repeat min max val)
(syntax-case #'min () (syntax-case #'min ()
[0 [0
(make-leaf)] (make-leaf)]

86
brag/codegen/flatten.rkt
Unescape Escape View File

@ -2,7 +2,6 @@
(require brag/rules/stx-types (require brag/rules/stx-types
racket/list racket/list
(for-syntax racket/base)) (for-syntax racket/base))
(require (except-in sugar/debug repeat))
(provide flatten-rule (provide flatten-rule
flatten-rules flatten-rules
prim-rule) prim-rule)
@ -69,78 +68,73 @@
(values (apply append (reverse rules)) (values (apply append (reverse rules))
(apply append (reverse patterns)))) (apply append (reverse patterns))))
(with-syntax ([head (if inferred? #'inferred-prim-rule #'prim-rule)] (with-syntax ([HEAD (if inferred? #'inferred-prim-rule #'prim-rule)]
[origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])]) [ORIGIN (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])])
(syntax-case a-rule (rule) (syntax-case a-rule (rule)
[(rule name pat) [(rule NAME PAT)
(syntax-case #'pat (id inferred-id lit token choice repeat maybe seq) (syntax-case #'PAT (id inferred-id lit token choice repeat maybe seq)
;; The primitive types stay as they are: ;; The primitive types stay as they are:
[(id val) [(id val)
(list #'(head origin name [pat]))] (list #'(HEAD ORIGIN NAME [PAT]))]
[(inferred-id val reason) [(inferred-id val reason)
(list #'(head origin name [pat]))] (list #'(HEAD ORIGIN NAME [PAT]))]
[(lit val) [(lit val)
(list #'(head origin name [pat]))] (list #'(HEAD ORIGIN NAME [PAT]))]
[(token val) [(token val)
(list #'(head origin name [pat]))] (list #'(HEAD ORIGIN NAME [PAT]))]
;; Everything else might need lifting: ;; Everything else might need lifting:
[(choice sub-pat ...) [(choice SUB-PAT ...)
(begin (begin
(define-values (inferred-ruless/rev new-sub-patss/rev) (define-values (inferred-ruless/rev new-sub-patss/rev)
(for/fold ([rs '()] [ps '()]) (for/fold ([rs '()] [ps '()])
([p (syntax->list #'(sub-pat ...))]) ([p (syntax->list #'(SUB-PAT ...))])
(let-values ([(new-r new-p) (let-values ([(new-r new-p)
(lift-nonprimitive-pattern p)]) (lift-nonprimitive-pattern p)])
(values (cons new-r rs) (cons new-p ps))))) (values (cons new-r rs) (cons new-p ps)))))
(with-syntax ([((sub-pat ...) ...) (reverse new-sub-patss/rev)]) (with-syntax ([((SUB-PAT ...) ...) (reverse new-sub-patss/rev)])
(append (list #'(head origin name [sub-pat ...] ...)) (append (list #'(HEAD ORIGIN NAME [SUB-PAT ...] ...))
(apply append (reverse inferred-ruless/rev)))))] (apply append (reverse inferred-ruless/rev)))))]
[(repeat min sub-pat) [(repeat MIN #f SUB-PAT)
;; indefinite repeat
(begin (begin
(define-values (inferred-rules new-sub-pats) (define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-pattern #'sub-pat)) (lift-nonprimitive-pattern #'SUB-PAT))
(report/file (syntax-e #'min)) (with-syntax ([(SUB-PAT ...) new-sub-pats]
(with-syntax ([(sub-pat ...) new-sub-pats] [MIN-REPEAT-SUB-PATS (apply append (make-list (syntax-e #'MIN) new-sub-pats))])
[MIN-REPEAT-SUB-PATS (apply append (make-list (syntax-e #'min) new-sub-pats))]) (cons #`(HEAD ORIGIN NAME
(cons (cond [(= (syntax-e #'min) 0) [(inferred-id NAME repeat) SUB-PAT ...]
#`(head origin name MIN-REPEAT-SUB-PATS)
[(inferred-id name repeat) sub-pat ...]
[])]
[(= (syntax-e #'min) 1)
#`(head origin name
[(inferred-id name repeat) sub-pat ...]
[sub-pat ...])]
[(= (syntax-e #'min) 2)
#`(head origin name
[(inferred-id name repeat) sub-pat ...]
[sub-pat ... sub-pat ...])])
inferred-rules)
#;(cons (report/file #`(head origin name
[(inferred-id name repeat) sub-pat ...]
MIN-REPEAT-SUB-PATS))
inferred-rules)))] inferred-rules)))]
[(repeat MIN MAX SUB-PAT)
[(maybe sub-pat) ;; finite repeat
(let ([min (syntax-e #'MIN)]
[max (syntax-e #'MAX)])
(recur
(with-syntax ([(MIN-SUBPAT ...) (make-list min #'SUB-PAT)]
[(EXTRA-SUBPAT ...) (make-list (- max min) #'SUB-PAT)])
#'(rule NAME (seq MIN-SUBPAT ... (maybe EXTRA-SUBPAT) ...)))
#f))]
[(maybe SUB-PAT)
(begin (begin
(define-values (inferred-rules new-sub-pats) (define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-pattern #'sub-pat)) (lift-nonprimitive-pattern #'SUB-PAT))
(report*/file #'pat #'sub-pat) (with-syntax ([(SUB-PAT ...) new-sub-pats])
(with-syntax ([(sub-pat ...) new-sub-pats]) (cons #'(HEAD ORIGIN NAME
(cons #'(head origin name [SUB-PAT ...]
[sub-pat ...]
[]) [])
inferred-rules)))] inferred-rules)))]
[(seq sub-pat ...) [(seq SUB-PAT ...)
(begin (begin
(define-values (inferred-rules new-sub-pats) (define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-patterns (syntax->list #'(sub-pat ...)))) (lift-nonprimitive-patterns (syntax->list #'(SUB-PAT ...))))
(with-syntax ([(sub-pat ...) new-sub-pats]) (with-syntax ([(SUB-PAT ...) new-sub-pats])
(cons #'(head origin name [sub-pat ...]) (cons #'(HEAD ORIGIN NAME [SUB-PAT ...])
inferred-rules)))])])))) inferred-rules)))])]))))
@ -174,7 +168,7 @@
#t] #t]
[(choice sub-pat ...) [(choice sub-pat ...)
#f] #f]
[(repeat min val) [(repeat min max val)
#f] #f]
[(maybe sub-pat) [(maybe sub-pat)
#f] #f]

12
brag/rules/parser.rkt
Unescape Escape View File

@ -4,7 +4,6 @@
racket/list racket/list
racket/match racket/match
"rule-structs.rkt") "rule-structs.rkt")
(require sugar/debug)
;; A parser for grammars. ;; A parser for grammars.
@ -158,21 +157,20 @@
(cond [(string=? $2 "*") (cond [(string=? $2 "*")
(pattern-repeat (position->pos $1-start-pos) (pattern-repeat (position->pos $1-start-pos)
(position->pos $2-end-pos) (position->pos $2-end-pos)
0 $1)] 0 #f $1)]
[(string=? $2 "+") [(string=? $2 "+")
(pattern-repeat (position->pos $1-start-pos) (pattern-repeat (position->pos $1-start-pos)
(position->pos $2-end-pos) (position->pos $2-end-pos)
1 $1)] 1 #f $1)]
[(regexp-match #px"^\\{(\\d+)?,?(\\d+)?\\}$" $2) ; "{min,max}" with both min & max optional [(regexp-match #px"^\\{(\\d+)?,?(\\d+)?\\}$" $2) ; "{min,max}" with both min & max optional
=> (λ (m) => (λ (m)
(match-define (cons min-repeat max-repeat) (match-define (cons min-repeat max-repeat)
(match m (match m
[(list _ min max) (cons (if min (string->number min) 0) [(list _ min max) (cons (if min (string->number min) 0)
(and max (string->number max)))])) (and max (string->number max)))]))
(report/file min-repeat)
(pattern-repeat (position->pos $1-start-pos) (pattern-repeat (position->pos $1-start-pos)
(position->pos $2-end-pos) (position->pos $2-end-pos)
min-repeat $1))] min-repeat max-repeat $1))]
[else [else
(error 'grammar-parse "unknown repetition operator ~e" $2)])] (error 'grammar-parse "unknown repetition operator ~e" $2)])]
[(atomic-pattern) [(atomic-pattern)
@ -233,8 +231,8 @@
(pattern-lit start-pos end-pos v (or hide? h))] (pattern-lit start-pos end-pos v (or hide? h))]
[(pattern-choice _ _ vs) [(pattern-choice _ _ vs)
(pattern-choice start-pos end-pos vs)] (pattern-choice start-pos end-pos vs)]
[(pattern-repeat _ _ m v) [(pattern-repeat _ _ min max v)
(pattern-repeat start-pos end-pos m v)] (pattern-repeat start-pos end-pos min max v)]
[(pattern-maybe _ _ v) [(pattern-maybe _ _ v)
(pattern-maybe start-pos end-pos v)] (pattern-maybe start-pos end-pos v)]
[(pattern-seq _ _ vs) [(pattern-seq _ _ vs)

3
brag/rules/rule-structs.rkt
Unescape Escape View File

@ -31,7 +31,8 @@
(struct pattern-choice pattern (vals) (struct pattern-choice pattern (vals)
#:transparent) #:transparent)
(struct pattern-repeat pattern (min ;; either 0 or 1 (struct pattern-repeat pattern (min
max
val) val)
#:transparent) #:transparent)

4
brag/rules/stx.rkt
Unescape Escape View File

@ -80,8 +80,8 @@
'hide hide)] 'hide hide)]
[(struct pattern-choice (start end vals)) [(struct pattern-choice (start end vals))
(datum->syntax #f`(choice ,@(map recur vals)) source-location)] (datum->syntax #f`(choice ,@(map recur vals)) source-location)]
[(struct pattern-repeat (start end min val)) [(struct pattern-repeat (start end min max val))
(datum->syntax #f`(repeat ,min ,(recur val)) source-location)] (datum->syntax #f`(repeat ,min ,max ,(recur val)) source-location)]
[(struct pattern-maybe (start end val)) [(struct pattern-maybe (start end val))
(datum->syntax #f`(maybe ,(recur val)) source-location)] (datum->syntax #f`(maybe ,(recur val)) source-location)]
[(struct pattern-seq (start end vals)) [(struct pattern-seq (start end vals))

Write Preview
Loading…
Cancel
Save