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

adjust flattening of zero-or-more rule (fixes #18)

Browse Source
pull/24/head
Matthew Butterick 5 years ago
parent 2612c3356b
commit d1ebde511a
5 changed files with 72 additions and 40 deletions
Show Stats Download Patch File Download Diff File

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

@ -6,38 +6,33 @@
flatten-rules flatten-rules
prim-rule) prim-rule)
(define (make-fresh-name) (define (make-fresh-name)
(let ([n 0]) (let ([n 0])
(lambda () (λ ()
(set! n (add1 n)) (set! n (add1 n))
(string->symbol (format "%rule~a" n))))) (string->symbol (format "%rule~a" n)))))
(define default-fresh-name (define default-fresh-name (make-fresh-name))
(make-fresh-name))
;; Translates rules to lists of primitive rules. ;; Translates rules to lists of primitive rules.
(define (flatten-rules rules #:fresh-name [fresh-name default-fresh-name]) (define (flatten-rules rules #:fresh-name [fresh-name default-fresh-name])
(define ht (make-hash)) (define ht (make-hasheq))
(apply append (map (lambda (a-rule) (flatten-rule a-rule (apply append (for/list ([a-rule (in-list rules)])
#:ht ht (flatten-rule a-rule
#:fresh-name fresh-name)) #:ht ht
rules))) #:fresh-name fresh-name))))
;; flatten-rule: rule -> (listof primitive-rule) ;; flatten-rule: rule -> (listof primitive-rule)
(define (flatten-rule a-rule (define (flatten-rule a-rule
#:fresh-name [fresh-name default-fresh-name] #:fresh-name [fresh-name default-fresh-name]
;; ht: (hashtableof pattern-hash-key pat) ;; ht: (hashtableof pattern-hash-key pat)
#:ht [ht (make-hash)]) #:ht [ht (make-hasheq)])
(let recur ([a-rule a-rule] (let recur ([a-rule a-rule] [inferred? #f])
[inferred? #f])
;; lift-nonprimitive-pattern: pattern -> (values (listof primitive-rule) pattern) ;; lift-nonprimitive-pattern: pattern -> (values (listof primitive-rule) pattern)
;; Turns non-primitive patterns into primitive patterns, and produces a set of ;; Turns non-primitive patterns into primitive patterns, and produces a set of
@ -98,6 +93,14 @@
(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 0 0 SUB-PAT)
;; repeat from 0 to 0 (is a no-op)
(recur #'(rule NAME (seq)) #f)]
[(repeat 0 MAYBE-MAX SUB-PAT)
;; repeat from 0 (as a maybe rule)
(recur #'(rule NAME (maybe (repeat 1 MAYBE-MAX SUB-PAT))) #f)]
[(repeat MIN #f SUB-PAT) [(repeat MIN #f SUB-PAT)
;; indefinite repeat ;; indefinite repeat
(begin (begin
@ -115,10 +118,15 @@
(begin (begin
(define min (syntax-e #'MIN)) (define min (syntax-e #'MIN))
(define max (syntax-e #'MAX)) (define max (syntax-e #'MAX))
(define new-rule-stx (with-syntax ([(MIN-SUBPAT ...) (make-list min #'SUB-PAT)] (unless (<= min max)
[(EXTRA-SUBPAT ...) (make-list (- max min) #'SUB-PAT)]) (raise-syntax-error #f (format "minimum repeat count cannot be larger than maximum, got {~a,~a}" min max) a-rule))
;; has to keep the same name to work correctly ;; has to keep the same rule NAME to work correctly
#'(rule NAME (seq MIN-SUBPAT ... (maybe EXTRA-SUBPAT) ...)))) (define new-rule-stx
(if (= min max)
(with-syntax ([MIN-SUBPATS (make-list min #'SUB-PAT)])
#'(rule NAME (seq . MIN-SUBPATS)))
(with-syntax ([REPEATS-REMAINING (- max min)]) ; REPEATS-REMAINING is a positive integer
#'(rule NAME (seq (repeat MIN MIN SUB-PAT) (repeat 0 REPEATS-REMAINING SUB-PAT))))))
(recur new-rule-stx #f))] (recur new-rule-stx #f))]
[(maybe SUB-PAT) [(maybe SUB-PAT)

3
brag/examples/nested-repeats.rkt
Unescape Escape View File

@ -0,0 +1,3 @@
#lang brag
start : ( (X | X Y) A* )*

1
brag/test/test-all.rkt
Unescape Escape View File

@ -12,6 +12,7 @@
"test-flatten.rkt" "test-flatten.rkt"
"test-hide-and-splice.rkt" "test-hide-and-splice.rkt"
"test-lexer.rkt" "test-lexer.rkt"
"test-nested-repeats.rkt"
"test-old-token.rkt" "test-old-token.rkt"
"test-parser.rkt" "test-parser.rkt"
"test-quotation-marks-and-backslashes.rkt" "test-quotation-marks-and-backslashes.rkt"

55
brag/test/test-flatten.rkt
Unescape Escape View File

@ -33,18 +33,18 @@
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule expr (seq (lit "1") (seq (lit "2") (lit "3")))))) (flatten-rule #'(rule expr (seq (lit "1") (seq (lit "2") (lit "3"))))))
'((prim-rule seq expr '((prim-rule seq expr
[(lit "1") (lit "2") (lit "3")]))) [(lit "1") (lit "2") (lit "3")])))
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule expr (seq (seq (lit "1") (lit "2")) (lit "3"))))) (flatten-rule #'(rule expr (seq (seq (lit "1") (lit "2")) (lit "3")))))
'((prim-rule seq expr '((prim-rule seq expr
[(lit "1") (lit "2") (lit "3")]))) [(lit "1") (lit "2") (lit "3")])))
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule expr (seq (seq (lit "1")) (seq (lit "2") (lit "3")))))) (flatten-rule #'(rule expr (seq (seq (lit "1")) (seq (lit "2") (lit "3"))))))
'((prim-rule seq expr '((prim-rule seq expr
[(lit "1") (lit "2") (lit "3")]))) [(lit "1") (lit "2") (lit "3")])))
@ -96,14 +96,16 @@
;; repeat ;; repeat
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule rule-2+ (repeat 0 #f (id rule-2))))) (flatten-rule #'(rule rule-2+ (repeat 0 #f (id rule-2)))))
'((prim-rule repeat rule-2+ '((prim-rule maybe rule-2+ ((inferred-id %rule1 repeat)) ())
[(inferred-id rule-2+ repeat) (id rule-2)] (inferred-prim-rule repeat %rule1
[]))) ((inferred-id %rule1 repeat) (id rule-2))
((id rule-2)))))
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule rule-2+ (repeat 0 #f (seq (lit "+") (id rule-2)))))) (flatten-rule #'(rule rule-2+ (repeat 0 #f (seq (lit "+") (id rule-2))))))
'((prim-rule repeat rule-2+ '((prim-rule maybe rule-2+ ((inferred-id %rule2 repeat)) ())
[(inferred-id rule-2+ repeat) (lit "+") (id rule-2)] (inferred-prim-rule repeat %rule2
[]))) ((inferred-id %rule2 repeat) (lit "+") (id rule-2))
((lit "+") (id rule-2)))))
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule rule-2+ (repeat 1 #f (id rule-2))))) (flatten-rule #'(rule rule-2+ (repeat 1 #f (id rule-2)))))
@ -132,8 +134,8 @@
[(lit "x")] [(lit "x")]
[(inferred-id r1 maybe)]) [(inferred-id r1 maybe)])
(inferred-prim-rule maybe r1 (inferred-prim-rule maybe r1
[(lit "y")] [(lit "y")]
[]))) [])))
;; choice, maybe, repeat ;; choice, maybe, repeat
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule sexp (choice (lit "x") (flatten-rule #'(rule sexp (choice (lit "x")
@ -143,11 +145,11 @@
[(lit "x")] [(lit "x")]
[(inferred-id r1 maybe)]) [(inferred-id r1 maybe)])
(inferred-prim-rule maybe r1 (inferred-prim-rule maybe r1
[(inferred-id r2 repeat)] [(inferred-id r2 repeat)]
[]) [])
(inferred-prim-rule repeat r2 (inferred-prim-rule repeat r2
[(inferred-id r2 repeat) (lit "y")] [(inferred-id r2 repeat) (lit "y")]
[(lit "y")]))) [(lit "y")])))
;; choice, seq ;; choice, seq
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule sexp (choice (seq (lit "x") (lit "y")) (flatten-rule #'(rule sexp (choice (seq (lit "x") (lit "y"))
@ -174,8 +176,11 @@
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule expr (seq (id term) (repeat 0 #f (seq (lit "+") (id term))))) (flatten-rule #'(rule expr (seq (id term) (repeat 0 #f (seq (lit "+") (id term)))))
#:fresh-name (make-fresh-name))) #:fresh-name (make-fresh-name)))
'((prim-rule seq expr [(id term) (inferred-id r1 repeat)]) '((prim-rule seq expr ((id term) (inferred-id r1 repeat)))
(inferred-prim-rule repeat r1 [(inferred-id r1 repeat) (lit "+") (id term)] []))) (prim-rule maybe r1 ((inferred-id r2 repeat)) ())
(inferred-prim-rule repeat r2
((inferred-id r2 repeat) (lit "+") (id term))
((lit "+") (id term)))))
;; larger example: simple arithmetic ;; larger example: simple arithmetic
@ -186,8 +191,14 @@
(rule factor (token INT)))) (rule factor (token INT))))
#:fresh-name (make-fresh-name))) #:fresh-name (make-fresh-name)))
'((prim-rule seq expr [(id term) (inferred-id r1 repeat)]) '((prim-rule seq expr ((id term) (inferred-id r1 repeat)))
(inferred-prim-rule repeat r1 [(inferred-id r1 repeat) (lit "+") (id term)] []) (prim-rule maybe r1 ((inferred-id r2 repeat)) ())
(prim-rule seq term [(id factor) (inferred-id r2 repeat)]) (inferred-prim-rule repeat r2
(inferred-prim-rule repeat r2 [(inferred-id r2 repeat) (lit "*") (id factor)] []) ((inferred-id r2 repeat) (lit "+") (id term))
(prim-rule token factor [(token INT)]))) ((lit "+") (id term)))
(prim-rule seq term ((id factor) (inferred-id r3 repeat)))
(prim-rule maybe r3 ((inferred-id r4 repeat)) ())
(inferred-prim-rule repeat r4
((inferred-id r4 repeat) (lit "*") (id factor))
((lit "*") (id factor)))
(prim-rule token factor ((token INT)))))

9
brag/test/test-nested-repeats.rkt
Unescape Escape View File

@ -0,0 +1,9 @@
#lang racket/base
(require brag/examples/nested-repeats
rackunit)
(check-equal?
(syntax->datum (parse (list "X" "Y" "X")))
'(start "X" "Y" "X"))
Write Preview
Loading…
Cancel
Save