From 17b01b3718c0be2d32b59889a523bdf4fee1ccf7 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 30 Apr 2019 09:07:41 -0700 Subject: [PATCH] simplify flattening --- brag/codegen/flatten.rkt | 42 ++++++-------- brag/test/test-flatten.rkt | 109 ++++++++++++++++++------------------- 2 files changed, 70 insertions(+), 81 deletions(-) diff --git a/brag/codegen/flatten.rkt b/brag/codegen/flatten.rkt index 1a4cbae..e39325e 100755 --- a/brag/codegen/flatten.rkt +++ b/brag/codegen/flatten.rkt @@ -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. diff --git a/brag/test/test-flatten.rkt b/brag/test/test-flatten.rkt index abfe918..273bbc3 100755 --- a/brag/test/test-flatten.rkt +++ b/brag/test/test-flatten.rkt @@ -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)))))