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

simplify flattening

Browse Source
pull/24/head
Matthew Butterick 6 years ago
parent d1ebde511a
commit 17b01b3718
2 changed files with 70 additions and 81 deletions
Show Stats Download Patch File Download Diff File

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

@ -71,24 +71,24 @@
;; 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 [(id val)]))]
[(inferred-id val reason) [(inferred-id val reason)
(list #'(HEAD ORIGIN NAME [PAT]))] (list #'(HEAD ORIGIN NAME [(inferred-id val reason)]))]
[(lit val) [(lit val)
(list #'(HEAD ORIGIN NAME [PAT]))] (list #'(HEAD ORIGIN NAME [(lit val)]))]
[(token val) [(token val)
(list #'(HEAD ORIGIN NAME [PAT]))] (list #'(HEAD ORIGIN NAME [(token val)]))]
;; 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 null]
([p (syntax->list #'(SUB-PAT ...))]) [ps null])
(let-values ([(new-r new-p) ([p (in-list (syntax->list #'(SUB-PAT ...)))])
(lift-nonprimitive-pattern p)]) (define-values (new-r new-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)))))]
@ -98,7 +98,7 @@
(recur #'(rule NAME (seq)) #f)] (recur #'(rule NAME (seq)) #f)]
[(repeat 0 MAYBE-MAX SUB-PAT) [(repeat 0 MAYBE-MAX SUB-PAT)
;; repeat from 0 (as a maybe rule) ;; repeat from 0 (as a `maybe` rule)
(recur #'(rule NAME (maybe (repeat 1 MAYBE-MAX SUB-PAT))) #f)] (recur #'(rule NAME (maybe (repeat 1 MAYBE-MAX SUB-PAT))) #f)]
[(repeat MIN #f SUB-PAT) [(repeat MIN #f SUB-PAT)
@ -108,13 +108,10 @@
(lift-nonprimitive-pattern #'SUB-PAT)) (lift-nonprimitive-pattern #'SUB-PAT))
(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 #`(HEAD ORIGIN NAME [(inferred-id NAME repeat) SUB-PAT ...] MIN-REPEAT-SUB-PATS) inferred-rules)))]
[(inferred-id NAME repeat) SUB-PAT ...]
MIN-REPEAT-SUB-PATS)
inferred-rules)))]
[(repeat MIN MAX SUB-PAT) [(repeat MIN MAX SUB-PAT)
;; finite repeat ;; finite repeat (special case of `seq`)
(begin (begin
(define min (syntax-e #'MIN)) (define min (syntax-e #'MIN))
(define max (syntax-e #'MAX)) (define max (syntax-e #'MAX))
@ -130,22 +127,15 @@
(recur new-rule-stx #f))] (recur new-rule-stx #f))]
[(maybe SUB-PAT) [(maybe SUB-PAT)
(begin ;; special case of `choice`
(define-values (inferred-rules new-sub-pats) (recur #'(rule NAME (choice (seq SUB-PAT) (seq))) #f)]
(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 (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)))])]))))
;; Given a pattern, return a key appropriate for a hash. ;; Given a pattern, return a key appropriate for a hash.

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

@ -76,35 +76,32 @@
;; maybe ;; maybe
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule expr (maybe (id rule-2))))) (flatten-rule #'(rule expr (maybe (id rule-2)))))
'((prim-rule maybe expr '((prim-rule choice expr ((id rule-2)) ())))
[(id rule-2)]
[])))
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule expr (maybe (token HUH))))) (flatten-rule #'(rule expr (maybe (token HUH)))))
'((prim-rule maybe expr '((prim-rule choice expr ((token HUH)) ())))
[(token HUH)]
[])))
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
(flatten-rule #'(rule expr (maybe (seq (lit "hello") (lit "world")))))) (flatten-rule #'(rule expr (maybe (seq (lit "hello") (lit "world"))))))
'((prim-rule maybe expr '((prim-rule choice expr ((lit "hello") (lit "world")) ())))
[(lit "hello") (lit "world")]
[])))
;; 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 maybe rule-2+ ((inferred-id %rule1 repeat)) ()) '((prim-rule choice rule-2+ ((inferred-id %rule1 seq)) ())
(inferred-prim-rule repeat %rule1 (inferred-prim-rule seq %rule1 ((inferred-id %rule2 repeat)))
((inferred-id %rule1 repeat) (id rule-2)) (inferred-prim-rule
repeat
%rule2
((inferred-id %rule2 repeat) (id rule-2))
((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 maybe rule-2+ ((inferred-id %rule2 repeat)) ()) '((prim-rule choice rule-2+ ((inferred-id %rule3 seq)) ())
(inferred-prim-rule repeat %rule2 (inferred-prim-rule seq %rule3 ((inferred-id %rule4 repeat)))
((inferred-id %rule2 repeat) (lit "+") (id rule-2)) (inferred-prim-rule
repeat
%rule4
((inferred-id %rule4 repeat) (lit "+") (id rule-2))
((lit "+") (id rule-2))))) ((lit "+") (id rule-2)))))
(check-equal? (map syntax->datum (check-equal? (map syntax->datum
@ -130,26 +127,22 @@
(flatten-rule #'(rule sexp (choice (lit "x") (flatten-rule #'(rule sexp (choice (lit "x")
(maybe (lit "y")))) (maybe (lit "y"))))
#:fresh-name (make-fresh-name))) #:fresh-name (make-fresh-name)))
'((prim-rule choice sexp '((prim-rule choice sexp ((lit "x")) ((inferred-id r1 maybe)))
[(lit "x")] (prim-rule choice r1 ((lit "y")) ())))
[(inferred-id r1 maybe)])
(inferred-prim-rule maybe r1
[(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")
(maybe (repeat 1 #f (lit "y"))))) (maybe (repeat 1 #f (lit "y")))))
#:fresh-name (make-fresh-name))) #:fresh-name (make-fresh-name)))
'((prim-rule choice sexp '((prim-rule choice sexp ((lit "x")) ((inferred-id r1 maybe)))
[(lit "x")] (prim-rule choice r1 ((inferred-id r2 seq)) ())
[(inferred-id r1 maybe)]) (inferred-prim-rule seq r2 ((inferred-id r3 repeat)))
(inferred-prim-rule maybe r1 (inferred-prim-rule
[(inferred-id r2 repeat)] repeat
[]) r3
(inferred-prim-rule repeat r2 ((inferred-id r3 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"))
@ -164,12 +157,9 @@
(flatten-rule #'(rule sexp (maybe (choice (seq (lit "x") (lit "y")) (flatten-rule #'(rule sexp (maybe (choice (seq (lit "x") (lit "y"))
(seq (lit "z") (lit "w"))))) (seq (lit "z") (lit "w")))))
#:fresh-name (make-fresh-name))) #:fresh-name (make-fresh-name)))
'((prim-rule maybe sexp '((prim-rule choice sexp ((inferred-id r1 seq)) ())
[(inferred-id r1 choice)] (inferred-prim-rule seq r1 ((inferred-id r2 choice)))
[]) (inferred-prim-rule choice r2 ((lit "x") (lit "y")) ((lit "z") (lit "w")))))
(inferred-prim-rule choice r1
[(lit "x") (lit "y")]
[(lit "z") (lit "w")])))
;; seq, repeat ;; seq, repeat
@ -177,9 +167,12 @@
(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)))
(prim-rule maybe r1 ((inferred-id r2 repeat)) ()) (prim-rule choice r1 ((inferred-id r2 seq)) ())
(inferred-prim-rule repeat r2 (inferred-prim-rule seq r2 ((inferred-id r3 repeat)))
((inferred-id r2 repeat) (lit "+") (id term)) (inferred-prim-rule
repeat
r3
((inferred-id r3 repeat) (lit "+") (id term))
((lit "+") (id term))))) ((lit "+") (id term)))))
@ -192,13 +185,19 @@
#: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)))
(prim-rule maybe r1 ((inferred-id r2 repeat)) ()) (prim-rule choice r1 ((inferred-id r2 seq)) ())
(inferred-prim-rule repeat r2 (inferred-prim-rule seq r2 ((inferred-id r3 repeat)))
((inferred-id r2 repeat) (lit "+") (id term)) (inferred-prim-rule
repeat
r3
((inferred-id r3 repeat) (lit "+") (id term))
((lit "+") (id term))) ((lit "+") (id term)))
(prim-rule seq term ((id factor) (inferred-id r3 repeat))) (prim-rule seq term ((id factor) (inferred-id r4 repeat)))
(prim-rule maybe r3 ((inferred-id r4 repeat)) ()) (prim-rule choice r4 ((inferred-id r5 seq)) ())
(inferred-prim-rule repeat r4 (inferred-prim-rule seq r5 ((inferred-id r6 repeat)))
((inferred-id r4 repeat) (lit "*") (id factor)) (inferred-prim-rule
repeat
r6
((inferred-id r6 repeat) (lit "*") (id factor))
((lit "*") (id factor))) ((lit "*") (id factor)))
(prim-rule token factor ((token INT))))) (prim-rule token factor ((token INT)))))

Write Preview
Loading…
Cancel
Save