diff --git a/brag/codegen/codegen.rkt b/brag/codegen/codegen.rkt index 14d6697..e2381f8 100755 --- a/brag/codegen/codegen.rkt +++ b/brag/codegen/codegen.rkt @@ -301,7 +301,7 @@ [explicit explicit]) ([v (in-list (syntax->list #'(vals ...)))]) (loop v implicit explicit))] - [(repeat min val) + [(repeat min max val) (loop #'val implicit explicit)] [(maybe val) (loop #'val implicit explicit)] @@ -379,7 +379,7 @@ (for/fold ([acc acc]) ([v (in-list (syntax->list #'(vals ...)))]) (loop v acc))] - [(repeat min val) + [(repeat min max val) (loop #'val acc)] [(maybe val) (loop #'val acc)] @@ -425,7 +425,7 @@ (define a-child (process-pattern v)) (sat:add-child! an-or-node a-child)) an-or-node)] - [(repeat min val) + [(repeat min max val) (syntax-case #'min () [0 (make-leaf)] diff --git a/brag/codegen/flatten.rkt b/brag/codegen/flatten.rkt index aeb1902..89ab7b2 100755 --- a/brag/codegen/flatten.rkt +++ b/brag/codegen/flatten.rkt @@ -2,7 +2,6 @@ (require brag/rules/stx-types racket/list (for-syntax racket/base)) -(require (except-in sugar/debug repeat)) (provide flatten-rule flatten-rules prim-rule) @@ -69,78 +68,73 @@ (values (apply append (reverse rules)) (apply append (reverse patterns)))) - (with-syntax ([head (if inferred? #'inferred-prim-rule #'prim-rule)] - [origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])]) + (with-syntax ([HEAD (if inferred? #'inferred-prim-rule #'prim-rule)] + [ORIGIN (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])]) (syntax-case a-rule (rule) - [(rule name pat) - (syntax-case #'pat (id inferred-id lit token choice repeat maybe seq) + [(rule NAME PAT) + (syntax-case #'PAT (id inferred-id lit token choice repeat maybe seq) ;; The primitive types stay as they are: [(id val) - (list #'(head origin name [pat]))] + (list #'(HEAD ORIGIN NAME [PAT]))] [(inferred-id val reason) - (list #'(head origin name [pat]))] + (list #'(HEAD ORIGIN NAME [PAT]))] [(lit val) - (list #'(head origin name [pat]))] + (list #'(HEAD ORIGIN NAME [PAT]))] [(token val) - (list #'(head origin name [pat]))] + (list #'(HEAD ORIGIN NAME [PAT]))] ;; Everything else might need lifting: - [(choice sub-pat ...) + [(choice SUB-PAT ...) (begin (define-values (inferred-ruless/rev new-sub-patss/rev) (for/fold ([rs '()] [ps '()]) - ([p (syntax->list #'(sub-pat ...))]) + ([p (syntax->list #'(SUB-PAT ...))]) (let-values ([(new-r new-p) (lift-nonprimitive-pattern p)]) (values (cons new-r rs) (cons new-p ps))))) - (with-syntax ([((sub-pat ...) ...) (reverse new-sub-patss/rev)]) - (append (list #'(head origin name [sub-pat ...] ...)) + (with-syntax ([((SUB-PAT ...) ...) (reverse new-sub-patss/rev)]) + (append (list #'(HEAD ORIGIN NAME [SUB-PAT ...] ...)) (apply append (reverse inferred-ruless/rev)))))] - [(repeat min sub-pat) + [(repeat MIN #f SUB-PAT) + ;; indefinite repeat (begin (define-values (inferred-rules new-sub-pats) - (lift-nonprimitive-pattern #'sub-pat)) - (report/file (syntax-e #'min)) - (with-syntax ([(sub-pat ...) new-sub-pats] - [MIN-REPEAT-SUB-PATS (apply append (make-list (syntax-e #'min) new-sub-pats))]) - (cons (cond [(= (syntax-e #'min) 0) - #`(head origin name - [(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)) + (lift-nonprimitive-pattern #'SUB-PAT)) + (with-syntax ([(SUB-PAT ...) new-sub-pats] + [MIN-REPEAT-SUB-PATS (apply append (make-list (syntax-e #'MIN) new-sub-pats))]) + (cons #`(HEAD ORIGIN NAME + [(inferred-id NAME repeat) SUB-PAT ...] + MIN-REPEAT-SUB-PATS) inferred-rules)))] - - [(maybe sub-pat) + [(repeat MIN MAX 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 (define-values (inferred-rules new-sub-pats) - (lift-nonprimitive-pattern #'sub-pat)) - (report*/file #'pat #'sub-pat) - (with-syntax ([(sub-pat ...) new-sub-pats]) - (cons #'(head origin name - [sub-pat ...] + (lift-nonprimitive-pattern #'SUB-PAT)) + (with-syntax ([(SUB-PAT ...) new-sub-pats]) + (cons #'(HEAD ORIGIN NAME + [SUB-PAT ...] []) inferred-rules)))] - [(seq sub-pat ...) + [(seq SUB-PAT ...) (begin (define-values (inferred-rules new-sub-pats) - (lift-nonprimitive-patterns (syntax->list #'(sub-pat ...)))) - (with-syntax ([(sub-pat ...) new-sub-pats]) - (cons #'(head origin name [sub-pat ...]) + (lift-nonprimitive-patterns (syntax->list #'(SUB-PAT ...)))) + (with-syntax ([(SUB-PAT ...) new-sub-pats]) + (cons #'(HEAD ORIGIN NAME [SUB-PAT ...]) inferred-rules)))])])))) @@ -174,7 +168,7 @@ #t] [(choice sub-pat ...) #f] - [(repeat min val) + [(repeat min max val) #f] [(maybe sub-pat) #f] diff --git a/brag/rules/parser.rkt b/brag/rules/parser.rkt index 93c794e..75f33ad 100755 --- a/brag/rules/parser.rkt +++ b/brag/rules/parser.rkt @@ -4,7 +4,6 @@ racket/list racket/match "rule-structs.rkt") -(require sugar/debug) ;; A parser for grammars. @@ -158,21 +157,20 @@ (cond [(string=? $2 "*") (pattern-repeat (position->pos $1-start-pos) (position->pos $2-end-pos) - 0 $1)] + 0 #f $1)] [(string=? $2 "+") (pattern-repeat (position->pos $1-start-pos) (position->pos $2-end-pos) - 1 $1)] + 1 #f $1)] [(regexp-match #px"^\\{(\\d+)?,?(\\d+)?\\}$" $2) ; "{min,max}" with both min & max optional => (λ (m) (match-define (cons min-repeat max-repeat) (match m [(list _ min max) (cons (if min (string->number min) 0) (and max (string->number max)))])) - (report/file min-repeat) (pattern-repeat (position->pos $1-start-pos) (position->pos $2-end-pos) - min-repeat $1))] + min-repeat max-repeat $1))] [else (error 'grammar-parse "unknown repetition operator ~e" $2)])] [(atomic-pattern) @@ -233,8 +231,8 @@ (pattern-lit start-pos end-pos v (or hide? h))] [(pattern-choice _ _ vs) (pattern-choice start-pos end-pos vs)] - [(pattern-repeat _ _ m v) - (pattern-repeat start-pos end-pos m v)] + [(pattern-repeat _ _ min max v) + (pattern-repeat start-pos end-pos min max v)] [(pattern-maybe _ _ v) (pattern-maybe start-pos end-pos v)] [(pattern-seq _ _ vs) diff --git a/brag/rules/rule-structs.rkt b/brag/rules/rule-structs.rkt index 5b5968e..262de1b 100755 --- a/brag/rules/rule-structs.rkt +++ b/brag/rules/rule-structs.rkt @@ -31,7 +31,8 @@ (struct pattern-choice pattern (vals) #:transparent) -(struct pattern-repeat pattern (min ;; either 0 or 1 +(struct pattern-repeat pattern (min + max val) #:transparent) diff --git a/brag/rules/stx.rkt b/brag/rules/stx.rkt index 9c66685..9d5f5dd 100755 --- a/brag/rules/stx.rkt +++ b/brag/rules/stx.rkt @@ -80,8 +80,8 @@ 'hide hide)] [(struct pattern-choice (start end vals)) (datum->syntax #f`(choice ,@(map recur vals)) source-location)] - [(struct pattern-repeat (start end min val)) - (datum->syntax #f`(repeat ,min ,(recur val)) source-location)] + [(struct pattern-repeat (start end min max val)) + (datum->syntax #f`(repeat ,min ,max ,(recur val)) source-location)] [(struct pattern-maybe (start end val)) (datum->syntax #f`(maybe ,(recur val)) source-location)] [(struct pattern-seq (start end vals))