diff --git a/brag/codegen/flatten.rkt b/brag/codegen/flatten.rkt index e39325e..1a4cbae 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 [(id val)]))] + (list #'(HEAD ORIGIN NAME [PAT]))] [(inferred-id val reason) - (list #'(HEAD ORIGIN NAME [(inferred-id val reason)]))] + (list #'(HEAD ORIGIN NAME [PAT]))] [(lit val) - (list #'(HEAD ORIGIN NAME [(lit val)]))] + (list #'(HEAD ORIGIN NAME [PAT]))] [(token val) - (list #'(HEAD ORIGIN NAME [(token val)]))] + (list #'(HEAD ORIGIN NAME [PAT]))] ;; Everything else might need lifting: [(choice SUB-PAT ...) (begin (define-values (inferred-ruless/rev new-sub-patss/rev) - (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)))) + (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))))) (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,10 +108,13 @@ (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 (special case of `seq`) + ;; finite repeat (begin (define min (syntax-e #'MIN)) (define max (syntax-e #'MAX)) @@ -121,21 +124,28 @@ (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) - ;; special case of `choice` - (recur #'(rule NAME (choice (seq SUB-PAT) (seq))) #f)] + (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)))] [(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 273bbc3..abfe918 100755 --- a/brag/test/test-flatten.rkt +++ b/brag/test/test-flatten.rkt @@ -76,33 +76,36 @@ ;; maybe (check-equal? (map syntax->datum (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 (flatten-rule #'(rule expr (maybe (token HUH))))) - '((prim-rule choice expr ((token HUH)) ()))) + '((prim-rule maybe expr + [(token HUH)] + []))) (check-equal? (map syntax->datum (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 (check-equal? (map syntax->datum (flatten-rule #'(rule rule-2+ (repeat 0 #f (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))))) + '((prim-rule maybe rule-2+ ((inferred-id %rule1 repeat)) ()) + (inferred-prim-rule repeat %rule1 + ((inferred-id %rule1 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 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))))) + '((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))))) (check-equal? (map syntax->datum (flatten-rule #'(rule rule-2+ (repeat 1 #f (id rule-2))))) @@ -127,22 +130,26 @@ (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))) - (prim-rule choice r1 ((lit "y")) ()))) - + '((prim-rule choice sexp + [(lit "x")] + [(inferred-id r1 maybe)]) + (inferred-prim-rule maybe 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))) - (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"))))) + '((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")]))) ;; choice, seq (check-equal? (map syntax->datum (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")) (seq (lit "z") (lit "w"))))) #:fresh-name (make-fresh-name))) - '((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"))))) + '((prim-rule maybe sexp + [(inferred-id r1 choice)] + []) + (inferred-prim-rule choice r1 + [(lit "x") (lit "y")] + [(lit "z") (lit "w")]))) ;; seq, repeat @@ -167,13 +177,10 @@ (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 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 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 @@ -185,19 +192,13 @@ #:fresh-name (make-fresh-name))) '((prim-rule seq expr ((id term) (inferred-id r1 repeat))) - (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))))) + (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)))))