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 5 years ago
parent d1ebde511a
commit 17b01b3718
2 changed files with 70 additions and 81 deletions
Show Stats Download Patch File Download Diff File

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

@ -71,24 +71,24 @@
;; The primitive types stay as they are:
[(id val)
(list #'(HEAD ORIGIN NAME [PAT]))]
(list #'(HEAD ORIGIN NAME [(id val)]))]
[(inferred-id val reason)
(list #'(HEAD ORIGIN NAME [PAT]))]
(list #'(HEAD ORIGIN NAME [(inferred-id val reason)]))]
[(lit val)
(list #'(HEAD ORIGIN NAME [PAT]))]
(list #'(HEAD ORIGIN NAME [(lit val)]))]
[(token val)
(list #'(HEAD ORIGIN NAME [PAT]))]
(list #'(HEAD ORIGIN NAME [(token val)]))]
;; Everything else might need lifting:
[(choice SUB-PAT ...)
(begin
(define-values (inferred-ruless/rev new-sub-patss/rev)
(for/fold ([rs '()] [ps '()])
([p (syntax->list #'(SUB-PAT ...))])
(let-values ([(new-r new-p)
(lift-nonprimitive-pattern p)])
(values (cons new-r rs) (cons new-p ps)))))
(for/fold ([rs null]
[ps null])
([p (in-list (syntax->list #'(SUB-PAT ...)))])
(define-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 ...] ...))
(apply append (reverse inferred-ruless/rev)))))]
@ -98,7 +98,7 @@
(recur #'(rule NAME (seq)) #f)]
[(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)]
[(repeat MIN #f SUB-PAT)
@ -108,13 +108,10 @@
(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)))]
(cons #`(HEAD ORIGIN NAME [(inferred-id NAME repeat) SUB-PAT ...] MIN-REPEAT-SUB-PATS) inferred-rules)))]
[(repeat MIN MAX SUB-PAT)
;; finite repeat
;; finite repeat (special case of `seq`)
(begin
(define min (syntax-e #'MIN))
(define max (syntax-e #'MAX))
@ -124,28 +121,21 @@
(define new-rule-stx
(if (= min max)
(with-syntax ([MIN-SUBPATS (make-list min #'SUB-PAT)])
#'(rule NAME (seq . MIN-SUBPATS)))
#'(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))]
[(maybe SUB-PAT)
(begin
(define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-pattern #'SUB-PAT))
(with-syntax ([(SUB-PAT ...) new-sub-pats])
(cons #'(HEAD ORIGIN NAME
[SUB-PAT ...]
[])
inferred-rules)))]
;; special case of `choice`
(recur #'(rule NAME (choice (seq SUB-PAT) (seq))) #f)]
[(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 ...])
inferred-rules)))])]))))
(cons #'(HEAD ORIGIN NAME [SUB-PAT ...]) inferred-rules)))])]))))
;; Given a pattern, return a key appropriate for a hash.

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

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

Write Preview
Loading…
Cancel
Save