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

Revert "simplify flattening"

Browse Source 
This reverts commit 17b01b3718.
pull/24/head
Matthew Butterick 6 years ago
parent 17b01b3718
commit 0901778f65
2 changed files with 81 additions and 70 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: ;; The primitive types stay as they are:
[(id val) [(id val)
(list #'(HEAD ORIGIN NAME [(id val)]))] (list #'(HEAD ORIGIN NAME [PAT]))]
[(inferred-id val reason) [(inferred-id val reason)
(list #'(HEAD ORIGIN NAME [(inferred-id val reason)]))] (list #'(HEAD ORIGIN NAME [PAT]))]
[(lit val) [(lit val)
(list #'(HEAD ORIGIN NAME [(lit val)]))] (list #'(HEAD ORIGIN NAME [PAT]))]
[(token val) [(token val)
(list #'(HEAD ORIGIN NAME [(token val)]))] (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 null] (for/fold ([rs '()] [ps '()])
[ps null]) ([p (syntax->list #'(SUB-PAT ...))])
([p (in-list (syntax->list #'(SUB-PAT ...)))]) (let-values ([(new-r new-p)
(define-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)))))]
@ -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,10 +108,13 @@
(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 [(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) [(repeat MIN MAX SUB-PAT)
;; finite repeat (special case of `seq`) ;; finite repeat
(begin (begin
(define min (syntax-e #'MIN)) (define min (syntax-e #'MIN))
(define max (syntax-e #'MAX)) (define max (syntax-e #'MAX))
@ -121,21 +124,28 @@
(define new-rule-stx (define new-rule-stx
(if (= min max) (if (= min max)
(with-syntax ([MIN-SUBPATS (make-list min #'SUB-PAT)]) (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 (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)))))) #'(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)
;; special case of `choice` (begin
(recur #'(rule NAME (choice (seq SUB-PAT) (seq))) #f)] (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)))]
[(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 ...]) inferred-rules)))])])))) (cons #'(HEAD ORIGIN NAME [SUB-PAT ...])
inferred-rules)))])]))))
;; Given a pattern, return a key appropriate for a hash. ;; Given a pattern, return a key appropriate for a hash.

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

@ -76,33 +76,36 @@
;; 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 choice expr ((id rule-2)) ()))) '((prim-rule maybe expr
[(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 choice expr ((token HUH)) ()))) '((prim-rule maybe expr
[(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 choice expr ((lit "hello") (lit "world")) ()))) '((prim-rule maybe expr
[(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 choice rule-2+ ((inferred-id %rule1 seq)) ()) '((prim-rule maybe rule-2+ ((inferred-id %rule1 repeat)) ())
(inferred-prim-rule seq %rule1 ((inferred-id %rule2 repeat))) (inferred-prim-rule repeat %rule1
(inferred-prim-rule ((inferred-id %rule1 repeat) (id rule-2))
repeat ((id rule-2)))))
%rule2
((inferred-id %rule2 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 choice rule-2+ ((inferred-id %rule3 seq)) ()) '((prim-rule maybe rule-2+ ((inferred-id %rule2 repeat)) ())
(inferred-prim-rule seq %rule3 ((inferred-id %rule4 repeat))) (inferred-prim-rule repeat %rule2
(inferred-prim-rule ((inferred-id %rule2 repeat) (lit "+") (id rule-2))
repeat ((lit "+") (id rule-2)))))
%rule4
((inferred-id %rule4 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)))))
@ -127,22 +130,26 @@
(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 ((lit "x")) ((inferred-id r1 maybe))) '((prim-rule choice sexp
(prim-rule choice r1 ((lit "y")) ()))) [(lit "x")]
[(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 ((lit "x")) ((inferred-id r1 maybe))) '((prim-rule choice sexp
(prim-rule choice r1 ((inferred-id r2 seq)) ()) [(lit "x")]
(inferred-prim-rule seq r2 ((inferred-id r3 repeat))) [(inferred-id r1 maybe)])
(inferred-prim-rule (inferred-prim-rule maybe r1
repeat [(inferred-id r2 repeat)]
r3 [])
((inferred-id r3 repeat) (lit "y")) (inferred-prim-rule repeat r2
((lit "y"))))) [(inferred-id r2 repeat) (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"))
@ -157,9 +164,12 @@
(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 choice sexp ((inferred-id r1 seq)) ()) '((prim-rule maybe sexp
(inferred-prim-rule seq r1 ((inferred-id r2 choice))) [(inferred-id r1 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
@ -167,13 +177,10 @@
(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 choice r1 ((inferred-id r2 seq)) ()) (prim-rule maybe r1 ((inferred-id r2 repeat)) ())
(inferred-prim-rule seq r2 ((inferred-id r3 repeat))) (inferred-prim-rule repeat r2
(inferred-prim-rule ((inferred-id r2 repeat) (lit "+") (id term))
repeat ((lit "+") (id term)))))
r3
((inferred-id r3 repeat) (lit "+") (id term))
((lit "+") (id term)))))
;; larger example: simple arithmetic ;; larger example: simple arithmetic
@ -185,19 +192,13 @@
#: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 choice r1 ((inferred-id r2 seq)) ()) (prim-rule maybe r1 ((inferred-id r2 repeat)) ())
(inferred-prim-rule seq r2 ((inferred-id r3 repeat))) (inferred-prim-rule repeat r2
(inferred-prim-rule ((inferred-id r2 repeat) (lit "+") (id term))
repeat ((lit "+") (id term)))
r3 (prim-rule seq term ((id factor) (inferred-id r3 repeat)))
((inferred-id r3 repeat) (lit "+") (id term)) (prim-rule maybe r3 ((inferred-id r4 repeat)) ())
((lit "+") (id term))) (inferred-prim-rule repeat r4
(prim-rule seq term ((id factor) (inferred-id r4 repeat))) ((inferred-id r4 repeat) (lit "*") (id factor))
(prim-rule choice r4 ((inferred-id r5 seq)) ()) ((lit "*") (id factor)))
(inferred-prim-rule seq r5 ((inferred-id r6 repeat))) (prim-rule token factor ((token INT)))))
(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